#!/usr/bin/perl -w # # tv_grab_zz_sdjson_sqlite # # Copyright (c) 2016, 2017 Gary Buhrmaster # # This code is distributed under the GNU General Public License v2 (GPLv2) # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # version 2 as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. # # # For extended help information run # tv_grab_zz_sdjson_sqlite --info # # # NOTE - Automated XMLTV testing will report failure since Schedules Direct # requires an account for downloading of data. The automated testing # likely needs a way (a new capability?) that indicates that the grabber # cannot be tested. In addition, for many real world lineups, we again # fall into the different interpretations of the terms "station" and # "channel". Unlike how XMLTV uses the term, we consider a "station" # as a programming entity which has a schedule of programs. A "channel" # is a technical means of delivering a particular "station". XMLTV # uses channel when they mean station. For many lineups (for example, # a cable/satellite provider, or OTA repeaters) the exact same "station" # is on multiple "channels", which results in "duplicate" messages from # the automated testing tool which presumes that the channels need not # be duplicated. In an ideal world, that might be true, but as the # channel (in XMLTV terms) is also overloaded with the display name # which is used for automated discovery and updates in PVRs, we report # each "channel" seperately, even when the "station" is the same. # # # Version history: # # 2025/01/16 - 1.138 - add deaf-signed subtitles element # 2024/08/02 - 1.137 - fix error handling in DB_open # 2024/01/27 - 1.136 - extend detail in schedules direct user-agent # 2024/01/27 - 1.135 - move from legacy cvs to modern versioning # 2024/01/25 - 1.134 - parameterize retries # 2024/01/25 - 1.133 - provide for extended video quality values # 2024/01/24 - 1.132 - default 3rdparty metadata in configure to enabled # 2024/01/24 - 1.131 - simplify 3rdparty metadata tests # 2024/01/23 - 1.130 - add tvmaze metadata # 2024/01/23 - 1.129 - provide fallback for program episode value # 2023/09/10 - 1.128 - protect against no database in manage-lineups # 2023/09/04 - 1.127 - various minor message text updates # 2023/09/04 - 1.126 - always download current account lineups # 2023/09/04 - 1.125 - improve retry logic for station schedules hashes # 2023/09/02 - 1.124 - protect against missing or malformed json string # 2023/09/01 - 1.123 - eliminate redundent json utf8 invokations # 2023/09/01 - 1.122 - update cast and crew mappings # 2023/08/31 - 1.121 - protect against missing or malformed json string # 2023/08/18 - 1.120 - adjust retry numbers # 2023/08/14 - 1.119 - add routeto option for Schedules Direct debugging # 2023/08/12 - 1.118 - limit potential messages for retry cases # 2023/08/11 - 1.117 - add in delay for schedule hash retry # 2023/08/11 - 1.116 - support schedule hash download retry # 2023/08/11 - 1.115 - remove last updated datetime support # 2023/08/11 - 1.114 - add in atsc 3.0 system type for get-lineup # 2023/07/19 - 1.113 - rename downloadQueued to downloadRetry # 2023/07/18 - 1.112 - remove legacy commented out code # 2023/07/17 - 1.111 - adjust _resetSession and _resetError usage # 2022/02/28 - 1.110 - improve token revalidation logic # 2022/02/24 - 1.109 - update pod for resturl option # 2022/02/24 - 1.108 - improve rating agency data validation # 2021/05/14 - 1.107 - allow specification of SD REST endpoint # 2021/05/14 - 1.106 - clean up some perl critic warnings # 2021/04/08 - 1.105 - update rating agency mappings # 2021/03/30 - 1.104 - add guest and self attributes to actors # 2021/03/29 - 1.103 - update cast and crew mappings # 2020/09/15 - 1.102 - update for cherry-pick typo correction # 2020/06/21 - 1.101 - rename scaledownload to scale-download # 2020/06/20 - 1.100 - add support for --scaledownload # 2020/06/12 - 1.99 - include programID in metadata # 2020/05/18 - 1.98 - support ordering of station logos # 2020/05/17 - 1.97 - explicitly specify stable sort # 2020/05/09 - 1.96 - improve passwordhash option handling # 2020/05/08 - 1.95 - improve metadata names based on feedback # 2020/05/08 - 1.94 - extend metadata with schedules direct values # 2020/05/08 - 1.93 - refactor obtainStationsSchedules # 2020/05/05 - 1.92 - error checking and handling improvements # 2020/05/05 - 1.91 - increase potential grabber concurrency phase 3 # 2020/04/27 - 1.90 - increase potential grabber concurrency phase 2 # 2020/04/26 - 1.89 - increase potential grabber concurrency phase 1 # 2020/04/23 - 1.88 - reorganize database open/validation # 2020/04/13 - 1.87 - additional validation of returned data # 2020/04/10 - 1.86 - refactor obtainStationsSchedulesHash # 2020/04/07 - 1.85 - partially revert location removal # 2020/04/07 - 1.84 - fix for manage-lineups channel selection # 2020/04/06 - 1.83 - fix for manage-lineups with no database # 2020/04/05 - 1.82 - change lineup to lineupID for obtainLineups # 2020/04/04 - 1.81 - refactor/rename obtainHeadends # 2020/04/02 - 1.80 - remove location from lineup displays # 2020/04/01 - 1.79 - do not validate postal code via regex # 2020/03/30 - 1.78 - robustify token reuse validation # 2020/03/28 - 1.77 - use obtainLineups where appropriate # 2020/03/28 - 1.76 - supplement lineup data with status data # 2020/03/27 - 1.75 - remove legacy (20131021) api name # 2020/03/23 - 1.74 - refactor obtainLineups to return lineup array # 2020/03/22 - 1.73 - allow Schedules Direct endpoint redirects # 2020/03/22 - 1.72 - reuse existing token when possible # 2020/03/18 - 1.71 - handle obtainAvailable undef # 2020/03/18 - 1.70 - minor whitespace cleanup # 2020/03/17 - 1.69 - stable output order # 2020/03/17 - 1.68 - return all icons for channels unless fixup # 2019/11/08 - 1.67 - handle no-download for list-lineups # 2018/12/21 - 1.66 - default 3rdparty metadata in configure to disabled # 2018/12/17 - 1.65 - clean up whitespace and duplicate lines # 2018/12/16 - 1.64 - add support for gracenote rating body advisories # 2018/12/15 - 1.63 - remove (no longer existing) schedule ratings # 2018/12/14 - 1.62 - 3rdparty metadata emission via configure # 2018/12/13 - 1.61 - add tvdb metadata # 2018/11/10 - 1.60 - include subscription info in additional paths # 2018/11/03 - 1.59 - additional protection against bad data # 2018/10/30 - 1.58 - initial protections against bad data # 2018/09/15 - 1.57 - support lineup selection by transmitter # 2018/09/15 - 1.56 - enhance obtainAvailble to use uri # 2018/09/14 - 1.55 - support explicit lineup name for --manage-lineup add # 2018/09/13 - 1.54 - revise previously-shown (new is new and no supplemental) # 2018/09/05 - 1.53 - multi-lineup plumbing - configure # 2018/09/05 - 1.52 - add initial Schedules Direct "IPTV" transport # 2018/09/05 - 1.51 - multi-lineup plumbing - getLineup (v2) # 2018/09/05 - 1.50 - provide proper bind data types # 2018/09/04 - 1.49 - support short-name in getLineup for other types # 2018/09/03 - 1.48 - use available channum # 2018/09/02 - 1.47 - remove dead code # 2018/09/02 - 1.46 - fix grammer # 2018/08/30 - 1.45 - multi-lineup plumbing - mainline code # 2018/08/30 - 1.44 - multi-lineup plumbing - getLineup # 2018/08/30 - 1.43 - multi-lineup plumbing - SD_isLineupFetchRequired # 2018/08/30 - 1.42 - multi-lineup plumbing - lineupValidate # 2018/08/30 - 1.41 - multi-lineup plumbing - channelWriter # 2018/08/29 - 1.40 - multi-lineup plumbing - SD_cleanLineups # 2018/08/29 - 1.39 - multi-lineup plumbing - canonical lineup details # 2018/08/25 - 1.38 - remove dead code # 2018/08/25 - 1.37 - minor whitespace adjustments # 2018/06/17 - 1.36 - handle deleted lineups not having description # 2018/02/03 - 1.35 - remove lang from channel display-name # 2018/02/03 - 1.34 - remove use warning nonfatal experimental in package # 2017/07/21 - 1.33 - dtd compliance. Only actors can have roles # 2017/06/19 - 1.32 - derive category from showtype # 2017/04/20 - 1.31 - provide fixup support # 2017/04/18 - 1.30 - fix typo (in version history) # 2017/04/06 - 1.29 - add supplemental SHow data to EPisodes # 2017/04/02 - 1.28 - misc. code cleanup # 2017/03/26 - 1.27 - misc. code cleanup # 2017/03/21 - 1.26 - fix sth typos # 2017/03/21 - 1.25 - fix trailing whitespace # 2016/09/10 - 1.24 - change (improve) cast mapping # 2016/09/10 - 1.23 - remove use warning nonfatal experimental decl # 2016/08/25 - 1.22 - no warning messages for malformed SD data if quiet # 2016/08/25 - 1.21 - additional error checking of SD data # 2016/08/24 - 1.20 - correct sql error reporting # 2016/08/03 - 1.19 - reflect multinational capability (and fix docs) # 2016/08/03 - 1.18 - rename grabber based on xmltv agreed convention # 2016/07/30 - 1.17 - don't report radio stations as tvshow category # 2016/07/30 - 1.16 - eliminate XML:Writer validation for performance # 2016/07/17 - 1.15 - use Digest::SHA rather than Digest::SHA1 # 2016/06/07 - 1.14 - support multipart episodes # 2016/06/07 - 1.13 - improved season/episode value checks # 2016/05/28 - 1.12 - add support for episodeImage # 2016/05/26 - 1.11 - use program duration as length # 2016/05/26 - 1.10 - hack for tv_find_grabbers source parsing of desc # 2016/05/25 - 1.9 - Support total seasons, and more robust validation # 2016/05/24 - 1.8 - retry limit updates and get-lineup improvements # 2016/05/21 - 1.7 - protect against bad json returned by server # 2016/05/21 - 1.6 - correct (mis)use of global variable in package # 2016/05/20 - 1.5 - minor output formatting improvements for xmltv_ns # 2016/05/19 - 1.4 - correct totalEpisodes output # 2016/05/19 - 1.3 - add support for totalEpisodes metadata # 2016/04/28 - 1.2 - update version number in history and output # 2016/04/23 - 1.1 - Minor update for improved(?) category ordering # 2016/04/01 - 1.0 - First release # eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}' if 0; # not running under some shell require 5.016; use feature ':5.16'; use strict; use warnings FATAL => 'all'; use warnings NONFATAL => qw(exec recursion internal malloc newline deprecated portable); no warnings 'once'; use utf8; STDERR->autoflush(1); # Autoflush STDERR use XMLTV; use XMLTV::Options qw/ParseOptions/; use XMLTV::Configure::Writer; use XMLTV::Configure qw/LoadConfig SaveConfig/; use XMLTV::Ask; use Getopt::Long; use XML::Writer; use Encode qw/decode encode/; use JSON; use Digest::SHA qw(sha1 sha1_hex sha1_base64); use File::Basename; use File::Which; use File::HomeDir; use File::Path qw(make_path); use DateTime; use DateTime::TimeZone; use DateTime::Format::ISO8601; use DateTime::Format::SQLite; use POSIX qw(strftime); use List::MoreUtils qw(natatime); use List::Util qw/min max/; use DBI; use DBI qw(:sql_types); use DBD::SQLite; use Scalar::Util qw/looks_like_number/; use Data::Dumper; use sort 'stable'; my $RFC2838_COMPLIANT = 1; # RFC2838 compliant station ids, which makes XMLTV # validate even though the docs say "SHOULD" not "MUST" my $SCRIPT_URL = 'https://github.com/garybuhrmaster/tv_grab_zz_sdjson_sqlite'; my $SCRIPT_NAME = basename("$0"); my $SCRIPT_NAME_DIR = dirname("$0"); my $SCRIPT_VERSION = '1.138'; my $SCRIPT_DB_VERSION = 2; # Used for script/db updates (see DB_open) my $SD_DESC = 'Schedules Direct'; my $SD_SITEURL = 'https://www.schedulesdirect.org'; my $SD_COMMENT = 'Note: This data has been downloaded from Schedules Direct, ' . 'and use of the data is restricted by the subscriber agreement ' . 'to non-commercial use with open source projects. Refer to ' . 'the Schedules Direct subscriber agreement for more information'; my $SD_SCHEDULE_HASH_CHUNK = 250; # Request stations schedules hash in chunk sizes my $SD_SCHEDULE_CHUNK = 1000; # Request stations schedules in chunk sizes my $SD_PROGRAM_CHUNK = 4000; # Request program data in chunk sizes my $SD_SCHEDULE_HASH_CHUNK_MAX = 5000; # Schedules Direct max request size my $SD_SCHEDULE_CHUNK_MAX = 5000; # Schedules Direct max request size my $SD_PROGRAM_CHUNK_MAX = 5000; # Schedules Direct max request size my $SD_SCHEDULE_HASH_RETRIES = 3; # Schedules Direct schedule hash request retries my $SD_SCHEDULE_RETRIES = 3; # Schedules Direct schedule request retries my $SD_PROGRAM_RETRIES = 3; # Schedules Direct program request retries my $JSON = JSON->new()->shrink(1)->utf8(1); my $SD = SchedulesDirect->new(UserAgent => "$SCRIPT_NAME ($^O) $SCRIPT_NAME/$SCRIPT_VERSION xmltv/$XMLTV::VERSION perl/" . sprintf("%vd", $^V) . " "); my $DBH; # DataBase Handle my $nowDateTime = DateTime->now( time_zone => 'UTC' ); my $nowDateTimeSQLite = DateTime::Format::SQLite->format_datetime($nowDateTime); my $GRABBER_FIXUPS = {}; # Grabber fixups for broken applications foreach my $fixup(split(':', $ENV{'TV_GRAB_TARGET_APPLICATION_FIXUPS'} || '')) { $GRABBER_FIXUPS->{$fixup} = undef; } my $quiet = 0; my $debug = 0; my $download = 1; my $passwordHash; my $resturl; my $routeto; my $opt; my $conf; # # We attempt to pick off the --passwordhash option due to # the XMLTV ParseOptions not allowing extra_options to be # processed in the configure stage. # Getopt::Long::Configure("pass_through"); GetOptions('passwordhash=s' => \$passwordHash); Getopt::Long::Configure("no_pass_through"); # # We attempt to pick off the --resturl option due to # the XMLTV ParseOptions not allowing extra_options to be # processed in the configure stage. # Getopt::Long::Configure("pass_through"); GetOptions('resturl=s' => \$resturl); Getopt::Long::Configure("no_pass_through"); if (defined($resturl)) { $SD->RESTUrl($resturl); } # # We attempt to pick off the --routeto option due to # the XMLTV ParseOptions not allowing extra_options to be # processed in the configure stage. # Getopt::Long::Configure("pass_through"); GetOptions('routeto=s' => \$routeto); Getopt::Long::Configure("no_pass_through"); if (defined($routeto)) { $SD->RouteTo($routeto); } ( $opt, $conf ) = ParseOptions ( { grabber_name => "$SCRIPT_NAME", capabilities => [qw/baseline manualconfig preferredmethod lineups apiconfig/], stage_sub => \&configureGrabber, listchannels_sub => \&listChannels, list_lineups_sub => \&listLineups, get_lineup_sub => \&getLineup, load_old_config_sub => \&loadOldConfig, preferredmethod => 'allatonce', version => "$SCRIPT_VERSION", description => 'Multinational (Schedules Direct JSON web services with SQLite DB)', extra_options => [qw/manage-lineups force-download download-only no-download passwordhash=s scale-download=f resturl=s routeto=s/], defaults => { days => 30 }, } ); $debug = $opt->{'debug'}; $quiet = $opt->{'quiet'}; $SD->Debug(1) if ($debug); # # Special case for managing lineups # # This should (possibly) be done at the Schedules Direct # site itself (as it is done now), or a seperate program, # but as of now, this is it. # if ($opt->{'manage-lineups'}) { manageLineups(); exit(0); } # # Verify we have what we need to proceed and # perform a few checks for things we do not # support # configValidate($conf, $opt); if ($opt->{'offset'} < 0) { # Note: While it is (in theory) possible to # support an offset of -1, it requires a # bit of hoop jumping to get that data from # Schedules Direct, and it is not really # considered to be worth it for the edge # cases that might exist. The data may be # in the database in some cases. print (STDERR "Offset value may not be less than 0\n"); exit(1); } if ($opt->{'days'} < 0) { print (STDERR "Day value may not be less than 0\n"); exit(1); } if (defined($opt->{'scale-download'}) && looks_like_number($opt->{'scale-download'})) { $SD_SCHEDULE_HASH_CHUNK = min($SD_SCHEDULE_HASH_CHUNK_MAX, max(1, int($SD_SCHEDULE_HASH_CHUNK * $opt->{'scale-download'}))); $SD_SCHEDULE_CHUNK = min($SD_SCHEDULE_CHUNK_MAX, max(1, int($SD_SCHEDULE_CHUNK * $opt->{'scale-download'}))); $SD_PROGRAM_CHUNK = min($SD_PROGRAM_CHUNK_MAX, max(1, int($SD_PROGRAM_CHUNK * $opt->{'scale-download'}))); } if (!defined(eval {require JSON::XS})) { print (STDERR "WARNING: Perl module JSON::XS not installed. JSON encode/decode performance will be poor.\n") if (!$quiet); } $download = 0 if ($opt->{'no-download'}); # # Various sql and statement handles for accessing our database # my $sql; my $sql0; my $sql1; my $sql2; my $sql3; my $sql4; my $sth; my $sth0; my $sth1; my $sth2; my $sth3; my $sth4; my $param; my $param0; my $param1; my $param2; my $param3; my $param4; # # Open database # print (STDERR "Opening the local database\n") if (!$quiet); DB_open($conf->{'database'}->[0]); # # Provide the ability to force a (mostly) complete download # for all data by deleting most of the data in the database, # making this (in effect) a "first download". # if ($opt->{'force-download'}) { print (STDERR " clearing existing database to force full download\n") if (!$quiet); DB_clean(); } # # If we are not downloading data, we need to verify # that the lineup is in the database now. # if (!$download) { lineupValidate($conf->{'lineup'}); my $token = DB_settingsGet('token'); $SD->Token($token) if (defined($token)); goto skipDownload; } # # Login and perform the usual checks # print (STDERR "Obtaining authentication token for Schedules Direct\n") if (!$quiet); SD_login(); my $expiry = $SD->accountExpiry; if (!defined($expiry)) { print (STDERR "Unable to obtain the account expiration date: " . $SD->ErrorString . "\n"); exit(1); } my $expiryDateTime = DateTime::Format::ISO8601->parse_datetime($expiry); print (STDERR " Schedules Direct account expires on " . $expiryDateTime . "\n") if (!$quiet); # # Start the download process # print (STDERR "Downloading data from Schedules Direct\n") if (!$quiet); # # Always make sure we have a current lineup list # print (STDERR " downloading account lineups from Schedules Direct\n") if (!$quiet); SD_downloadLineups(); # # Validate that the configured lineup exists in our database # lineupValidate($conf->{'lineup'}); # # Get our current Schedules Direct maps (channels and # stations) for our lineup and feed to our DB if needed # for my $lineup(@{$conf->{'lineup'}}) { if (SD_isLineupFetchRequired([$lineup])) { print (STDERR " downloading channel and station maps for lineup $lineup \n") if (!$quiet); SD_downloadLineupMaps($lineup); } else { print (STDERR " not downloading channel and station maps for lineup $lineup (data current)\n") if (!$quiet); } } # # Obtain the current schedule hash values for our lineup stations # for (my $retry = 0; $retry < ($SD_SCHEDULE_HASH_RETRIES + 1); $retry++) { my $downloadRetry = 0; $sql = 'select distinct stations.station from stations as stations where stations.station in (select distinct channels.station from channels as channels where channels.lineup in ( ' . join(', ', ('?') x scalar(@{$conf->{'lineup'}})) . ' ) and channels.selected = 1)'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $param = 1; for (my $i=0; $i < scalar(@{$conf->{'lineup'}}); $i++) { $sth->bind_param( $param, @{$conf->{'lineup'}}[$i], SQL_VARCHAR); $param++; } $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); my $stationsSchedulesHashList = $sth->fetchall_arrayref([0]); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; print (STDERR " downloading station schedule hashes for " . scalar(@{$stationsSchedulesHashList}) . " stations" . (($retry == 0) ? "" : " (retry $retry)") . "\n") if (!$quiet); sleep(min(30, (10 * $retry))); my $stationsSchedulesHashIter; $stationsSchedulesHashIter = natatime $SD_SCHEDULE_HASH_CHUNK, @{$stationsSchedulesHashList}; while(my @chunk = $stationsSchedulesHashIter->()) { print (STDERR " downloading schedule hashes for " . scalar(@chunk) . " stations in this chunk\n") if ((!$quiet) && ((scalar(@chunk) != scalar(@{$stationsSchedulesHashList})))); my $stationsSchedulesHashRequest = []; foreach (@chunk) { my $s = {}; $s->{'stationID'} = $_->[0]; push(@{$stationsSchedulesHashRequest}, $s); } my $r = $SD->obtainStationsSchedulesHash(@{$stationsSchedulesHashRequest}); if (!defined($r)) { if ($downloadRetry < 10) { print (STDERR "Unexpected error when obtaining station schedules hashes: " . $SD->ErrorString() . " (will retry)\n"); } $downloadRetry++; } if (ref($r) ne 'ARRAY') { if ($downloadRetry < 10) { print (STDERR "Unexpected return data type " . ref($r) . " when obtaining station schedules hashes. (will retry)\n"); } $downloadRetry++; } $sql = "replace into stations_schedules_hash (station, day, hash, details) values ( ?, ?, ?, ?)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } foreach my $e(@{$r}) { if (ref($e) ne 'HASH') { if ($downloadRetry < 10) { print (STDERR "Unexpected return data type " . ref($e) . " while iterating station schedules hashes (will retry)\n"); } $downloadRetry++; next; } my $code = $e->{'code'} || 0; if ($code != 0) { if ($code == 7100) # request queued { if ($downloadRetry < 10) { print (STDERR "Request for schedule queued when obtaining station schedules hashes: (will retry)\n") if (!$quiet); } $downloadRetry++; } next; } if ((!defined($e->{'stationID'})) || (!defined($e->{'date'})) || ((substr($e->{'date'}, 0, 10)) !~ /^\d{4}-\d{2}-\d{2}$/) || (!defined($e->{'MD5'}))) { if ($downloadRetry < 10) { print (STDERR "Station, date, or hash not provided while iterating station schedules hashes (will retry)\n"); } $downloadRetry++; next; } my $station = $e->{'stationID'}; my $date = substr($e->{'date'}, 0, 10); my $hash = $e->{'MD5'}; my $details = $JSON->encode($e); $sth->bind_param( 1, $station, SQL_VARCHAR ); $sth->bind_param( 2, $date, SQL_DATE ); $sth->bind_param( 3, $hash, SQL_VARCHAR ); $sth->bind_param( 4, $details, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } } $DBH->commit(); undef $sth; } if (!$downloadRetry) { # # Indicate we have downloaded the data # $sql = 'update lineups set downloaded = ? where lineup in ( ' . join(', ', ('?') x scalar(@{$conf->{'lineup'}})) . ' )'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $param = 1; $sth->bind_param( $param, $nowDateTimeSQLite, SQL_DATETIME ); $param++; for (my $i=0; $i < scalar(@{$conf->{'lineup'}}); $i++) { $sth->bind_param( $param, @{$conf->{'lineup'}}[$i], SQL_VARCHAR); $param++; } $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; # # And we are done here # last; } } # # Obtain the station schedules for days for which we do # not have current information based on hash values and # feed to our DB # for (my $retry = 0; $retry < ($SD_SCHEDULE_RETRIES + 1); $retry++) { my $downloadRetry = 0; my $startDateTime = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'}); my $endDateTime = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'})->add(days => $opt->{'days'}); # # Note that we only update schedules (if needed) for days which will # produce reports for. This may, in some cases, reduce the overheads # # Note also that it is important to check for the day to be >= today # in order to skip retrieving schedules where the hash is obsolete. # Since Schedules Direct does not update past station_schedules, but # we keep them around for a bit, our past schedule hash can be invalid, # but we do not want to force a request for such schedules, which would # likely fail since Schedules Direct does not make available data # which older than (about) 24 hours ago. # $sql = "select distinct stations_schedules_hash.station, stations_schedules_hash.day from stations_schedules_hash as stations_schedules_hash " . " left outer join schedules_hash as schedules_hash on stations_schedules_hash.station = schedules_hash.station " . " AND stations_schedules_hash.day = schedules_hash.day " . " where (stations_schedules_hash.station in (select distinct channels.station " . " from channels as channels where channels.lineup in ( " . join(', ', ('?') x scalar(@{$conf->{'lineup'}})) . " ) " . " and channels.selected = 1)) " . " AND (schedules_hash.station is NULL OR schedules_hash.hash != stations_schedules_hash.hash) " . " AND stations_schedules_hash.day >= ? AND stations_schedules_hash.day < ? " . " ORDER by stations_schedules_hash.station, stations_schedules_hash.day"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $param = 1; for (my $i=0; $i < scalar(@{$conf->{'lineup'}}); $i++) { $sth->bind_param( $param, @{$conf->{'lineup'}}[$i], SQL_VARCHAR); $param++; } $sth->bind_param( $param, DateTime::Format::SQLite->format_date($startDateTime), SQL_DATE ); $param++; $sth->bind_param( $param, DateTime::Format::SQLite->format_date($endDateTime), SQL_DATE ); $param++; $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_DATE ); my $stationsSchedulesList = $sth->fetchall_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; if (scalar(@{$stationsSchedulesList}) == 0) { if ($retry == 0) { print (STDERR " not downloading daily schedules (data current)\n") if (!$quiet); } last; } print (STDERR " downloading " . scalar(@{$stationsSchedulesList}) . " new, updated, or missing daily schedules" . (($retry == 0) ? "" : " (retry $retry)") . "\n") if (!$quiet); sleep(min(30, (10 * $retry))); my $schedulesIter; $schedulesIter = natatime $SD_SCHEDULE_CHUNK, @{$stationsSchedulesList}; while(my @chunk = $schedulesIter->()) { print (STDERR " downloading " . scalar(@chunk) . " new, updated, or missing daily schedules in this chunk\n") if ((!$quiet) && ((scalar(@chunk) != scalar(@{$stationsSchedulesList})))); my $stationsSchedulesRequest = []; foreach (@chunk) { my $s = {}; $s->{'stationID'} = $_->[0]; $s->{'date'} = [$_->[1]]; push (@{$stationsSchedulesRequest}, ($s)); } my $r = $SD->obtainStationsSchedules(@{$stationsSchedulesRequest}); if (!defined($r)) { # For some reason, sometimes Schedules Direct returns malformed response (I believe due to # their optimization for the program array returns, which can result in partial data). # We will force a retry under those conditions. if ($downloadRetry < 10) { print (STDERR "Unexpected error when obtaining station schedules: " . $SD->ErrorString() . " (will retry)\n") if (!$quiet); } $downloadRetry++; next; } if (ref($r) ne 'ARRAY') { # For some reason, sometimes Schedules Direct returns malformed response (I believe due to # their optimization for the program array returns, which can result in partial data). # We will force a retry under those conditions. if ($downloadRetry < 10) { print (STDERR "Unexpected error when obtaining station schedules: " . $SD->ErrorString() . " (will retry)\n") if (!$quiet); } $downloadRetry++; next; } $sql1 = "delete from schedules where station = ? and day = ?"; $sql2 = "replace into schedules (station, day, starttime, duration, program, program_hash, details) values (?, ?, ?, ?, ?, ?, ?)"; $sql3 = "replace into schedules_hash (station, day, hash) values (?, ?, ?)"; $sth1 = $DBH->prepare_cached($sql1); if (!defined($sth1)) { print (STDERR "Unexpected error when preparing statement ($sql1): " . $DBH->errstr . "\n"); exit(1); } $sth2 = $DBH->prepare_cached($sql2); if (!defined($sth2)) { print (STDERR "Unexpected error when preparing statement ($sql2): " . $DBH->errstr . "\n"); exit(1); } $sth3 = $DBH->prepare_cached($sql3); if (!defined($sth3)) { print (STDERR "Unexpected error when preparing statement ($sql3): " . $DBH->errstr . "\n"); exit(1); } foreach my $sched(@{$r}) { my $hash = $sched->{'MD5'}; my $dayDateTime; $dayDateTime = DateTime::Format::ISO8601->parse_datetime($sched->{'date'}) if (defined($sched->{'date'})); my $sID = $sched->{'stationID'}; my $code = $sched->{'code'} || 0; if ($code != 0) { if ($code == 7100) # request queued { if ($downloadRetry < 10) { print (STDERR "Request for schedule queued when obtaining station schedules: (will retry)\n") if (!$quiet); } $downloadRetry++; } next; } my $programs = $sched->{'programs'}; if ((!defined($hash)) || (!defined($dayDateTime)) || (!defined($programs))) { next; } $sth1->bind_param( 1, $sID, SQL_VARCHAR ); $sth1->bind_param( 2, DateTime::Format::SQLite->format_date($dayDateTime), SQL_DATE ); $sth1->execute(); if ($sth1->err) { print (STDERR "Unexpected error when executing statement ($sql1): " . $sth1->errstr . "\n"); $DBH->rollback(); exit(1); } foreach my $program(@{$programs}) { my $pID = $program->{'programID'}; my $airDateTime = $program->{'airDateTime'}; my $duration = $program->{'duration'}; my $phash = $program->{'md5'}; my $details = $JSON->encode($program); if ((!defined($duration)) || (!defined($phash)) || (!defined($pID)) || (!defined($airDateTime))) { print (STDERR "Unexpected parsing error in program (data malformed) in schedule for $sID on " . $sched->{'date'} . ", skipping\n") if (!$quiet); next; } my $starttime = DateTime::Format::ISO8601->parse_datetime($airDateTime); $sth2->bind_param( 1, $sID, SQL_VARCHAR ); $sth2->bind_param( 2, DateTime::Format::SQLite->format_date($dayDateTime), SQL_DATE ); $sth2->bind_param( 3, DateTime::Format::SQLite->format_datetime($starttime), SQL_DATETIME ); $sth2->bind_param( 4, $duration, SQL_INTEGER ); $sth2->bind_param( 5, $pID, SQL_VARCHAR ); $sth2->bind_param( 6, $phash, SQL_VARCHAR ); $sth2->bind_param( 7, $details, SQL_VARCHAR ); $sth2->execute(); if ($sth2->err) { print (STDERR "Unexpected error when executing statement ($sql2): " . $sth2->errstr . "\n"); $DBH->rollback(); exit(1); } } $sth3->bind_param( 1, $sID, SQL_VARCHAR ); $sth3->bind_param( 2, DateTime::Format::SQLite->format_date($dayDateTime), SQL_DATE ); $sth3->bind_param( 3, $hash, SQL_VARCHAR ); $sth3->execute(); if ($sth3->err) { print (STDERR "Unexpected error when executing statement ($sql3): " . $sth3->errstr . "\n"); $DBH->rollback(); exit(1); } } $DBH->commit(); undef $sth1; undef $sth2; undef $sth3; } # We are done unless one (or more) entities indicate that the server queued the request or needs to retry last if (!$downloadRetry); } # # Obtain the program information for programs for which # we do not have current information based on hash values # and feed to our DB # for (my $retry = 0; $retry < ($SD_PROGRAM_RETRIES + 1); $retry++) { my $downloadRetry = 0; my $startDateTime = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'}); my $endDateTime = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'})->add(days => $opt->{'days'}); # # Note that we only update programs (if needed) for days which will # produce reports for. This may, in some cases, reduce the overheads # # Note also that it is important to check for the day to be >= today # in order to skip retrieving programs where the program hash is # obsolete. Since Schedules Direct does not update past schedules, # but we keep then around for a bit, our past program hash can # be invalid, but we do not want to request such programs (since # the program hash will be updated). # $sql = "select distinct schedules.program from schedules as schedules " . " left outer join programs as programs on schedules.program = programs.program " . " where (schedules.station in (select distinct stations.station " . " from stations as stations where stations.station " . " in (select distinct channels.station from channels channels " . " where channels.lineup in ( " . join(', ', ('?') x scalar(@{$conf->{'lineup'}})) . " ) and channels.selected = 1)) " . " AND (programs.program is null OR schedules.program_hash != programs.hash)) " . " AND schedules.day >= ? AND schedules.day < ?" ; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $param = 1; for (my $i=0; $i < scalar(@{$conf->{'lineup'}}); $i++) { $sth->bind_param( $param, @{$conf->{'lineup'}}[$i], SQL_VARCHAR); $param++; } $sth->bind_param( $param, DateTime::Format::SQLite->format_date($startDateTime), SQL_DATE ); $param++; $sth->bind_param( $param, DateTime::Format::SQLite->format_date($endDateTime), SQL_DATE ); $param++; $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); my $programsList = $sth->fetchall_arrayref([0]); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; if (scalar(@{$programsList}) == 0) { if ($retry == 0) { print (STDERR " not downloading programs (data current)\n") if (!$quiet); } last; } print (STDERR " downloading " . scalar(@{$programsList}) . " new, updated, or missing programs" . (($retry == 0) ? "" : " (retry $retry)") . "\n") if (!$quiet); sleep(min(30, (10 * $retry))); my $programsIter; $programsIter = natatime $SD_PROGRAM_CHUNK, @{$programsList}; while(my @chunk = $programsIter->()) { print (STDERR " downloading " . scalar(@chunk) . " new, updated, or missing programs in this chunk\n") if ((!$quiet) && ((scalar(@chunk) != scalar(@{$programsList})))); my $pl = []; foreach (@chunk) { push (@{$pl}, $_->[0]); } my $r = $SD->obtainPrograms(@{$pl}); if (!defined($r)) { # For some reason, sometimes Schedules Direct returns malformed response (I believe due to # their optimization for the program array returns, which can result in partial data). # We will force a retry under those conditions. if ($downloadRetry < 10) { print (STDERR "Unexpected error when obtaining programs: " . $SD->ErrorString() . " (will retry)\n") if (!$quiet); } $downloadRetry++; next; } if (ref($r) ne 'ARRAY') { # For some reason, sometimes Schedules Direct return malformed response (I believe due to # their optiomization for the program array returns, which can result in partial data). # We will force a retry under those conditions. if ($downloadRetry < 10) { print (STDERR "Unexpected return data type " . ref($r) . " when obtaining program array (will retry)\n") if (!$quiet); } $downloadRetry++; next; } $sql1 = "replace into programs (program, hash, details, program_supplemental, downloaded) values (?, ?, ?, ?, ?)"; $sth1 = $DBH->prepare_cached($sql1); if (!defined($sth1)) { print (STDERR "Unexpected error when preparing statement ($sql1): " . $DBH->errstr . "\n"); exit(1); } foreach my $program(@{$r}) { my $pID = $program->{'programID'}; next if (!defined($pID)); my $hash = $program->{'md5'} || 0; my $code = $program->{'code'} || 0; if ($code != 0) { if ($code == 6001) # request queued { if ($downloadRetry < 10) { print (STDERR "Request for program queued when obtaining program data: (will retry)\n") if (!$quiet); } $downloadRetry++; } next; } my $details = $JSON->encode($program); my $supplemental; if (substr($pID, 0, 2) eq 'EP') { $supplemental = 'SH' . substr($pID, 2, 8) . '0000'; } $sth1->bind_param( 1, $pID, SQL_VARCHAR ); $sth1->bind_param( 2, $hash, SQL_VARCHAR ); $sth1->bind_param( 3, $details, SQL_VARCHAR ); $sth1->bind_param( 4, $supplemental, SQL_VARCHAR ); $sth1->bind_param( 5, $nowDateTimeSQLite, SQL_DATETIME ); $sth1->execute(); if ($sth1->err) { print (STDERR "Unexpected error when executing statement ($sql1): " . $sth1->errstr . "\n"); $DBH->rollback(); exit(1); } } $DBH->commit(); undef $sth1; } # We are done unless one (or more) entities indicate that the server queued the request or needs to retry last if (!$downloadRetry); } # # Obtain the program supplemental information for programs # for which we do not have current information # for (my $retry = 0; $retry < ($SD_PROGRAM_RETRIES + 1); $retry++) { my $startDateTime = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'}); my $endDateTime = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'})->add(days => $opt->{'days'}); my $downloadRetry = 0; # Select all necessary supplemental program entities, and # randomly select others with an age bias (older more likely) $sql = "select distinct p1.program_supplemental from programs as p1 " . " left join programs as supplemental on supplemental.program = p1.program_supplemental " . " where p1.program_supplemental is not null " . " and ( (supplemental.program is null) " . " or ((((julianday('now') - julianday(supplemental.downloaded)) / 30.0) + " . " (0.5 - random() / cast(-9223372036854775808 as real) / 2.0)) > 1.40 )) " . " and p1.program in ( select schedules.program from schedules as schedules " . " where (schedules.station in (select distinct stations.station from stations as stations " . " where stations.station in (select distinct channels.station from channels channels " . " where channels.lineup in ( " . join(', ', ('?') x scalar(@{$conf->{'lineup'}})) . " ) " . " and channels.selected = 1)) " . " and schedules.day >= ? and schedules.day < ? ) ) "; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $param = 1; for (my $i=0; $i < scalar(@{$conf->{'lineup'}}); $i++) { $sth->bind_param( $param, @{$conf->{'lineup'}}[$i], SQL_VARCHAR); $param++; } $sth->bind_param( $param, DateTime::Format::SQLite->format_date($startDateTime), SQL_DATE ); $param++; $sth->bind_param( $param, DateTime::Format::SQLite->format_date($endDateTime), SQL_DATE ); $param++; $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col(1, undef, SQL_VARCHAR ); my $programsList = $sth->fetchall_arrayref([0]); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; if (scalar(@{$programsList}) == 0) { if ($retry == 0) { print (STDERR " not downloading programs for supplemental data (data current)\n") if (!$quiet); } last; } print (STDERR " downloading " . scalar(@{$programsList}) . " new, updated, or missing programs for supplemental data" . (($retry == 0) ? "" : " (retry $retry)") . "\n") if (!$quiet); sleep(min(30, (10 * $retry))); my $programsIter; $programsIter = natatime $SD_PROGRAM_CHUNK, @{$programsList}; while(my @chunk = $programsIter->()) { print (STDERR " downloading " . scalar(@chunk) . " new, updated, or missing programs for supplemental data in this chunk\n") if ((!$quiet) && ((scalar(@chunk) != scalar(@{$programsList})))); my $pl = []; foreach (@chunk) { push (@{$pl}, $_->[0]); } my $r = $SD->obtainPrograms(@{$pl}); if (!defined($r)) { # For some reason, sometimes Schedules Direct returns malformed response (I believe due to # their optimization for the program array returns, which can result in partial data). # We will force a retry under those conditions. if ($downloadRetry < 10) { print (STDERR "Unexpected error when obtaining programs: " . $SD->ErrorString() . " (will retry)\n") if (!$quiet); } $downloadRetry++; next; } if (ref($r) ne 'ARRAY') { # For some reason, sometimes Schedules Direct return malformed response (I believe due to # their optiomization for the program array returns, which can result in partial data). # We will force a retry under those conditions. if ($downloadRetry < 10) { print (STDERR "Unexpected return data type " . ref($r) . " when obtaining program array (will retry)\n") if (!$quiet); } $downloadRetry++; next; } $sql1 = "replace into programs (program, hash, details, program_supplemental, downloaded) values (?, ?, ?, ?, ?)"; $sth1 = $DBH->prepare_cached($sql1); if (!defined($sth1)) { print (STDERR "Unexpected error when preparing statement ($sql1): " . $DBH->errstr . "\n"); exit(1); } foreach my $program(@{$r}) { my $pID = $program->{'programID'}; next if (!defined($pID)); my $hash = $program->{'md5'} || 0; my $code = $program->{'code'} || 0; if ($code != 0) { if ($code == 6001) # request queued { if ($downloadRetry < 10) { print (STDERR "Request for program queued when obtaining program data: (will retry)\n") if (!$quiet); } $downloadRetry++; } next; } my $details = $JSON->encode($program); my $supplemental; if (substr($pID, 0, 2) eq 'EP') { $supplemental = 'SH' . substr($pID, 2, 8) . '0000'; } $sth1->bind_param( 1, $pID, SQL_VARCHAR ); $sth1->bind_param( 2, $hash, SQL_VARCHAR ); $sth1->bind_param( 3, $details, SQL_VARCHAR ); $sth1->bind_param( 4, $supplemental, SQL_VARCHAR ); $sth1->bind_param( 5, $nowDateTimeSQLite, SQL_DATETIME ); $sth1->execute(); if ($sth1->err) { print (STDERR "Unexpected error when executing statement ($sql1): " . $sth1->errstr . "\n"); $DBH->rollback(); exit(1); } } $DBH->commit(); undef $sth1; } # We are done unless one (or more) entities indicate that the server queued the request or needs to retry last if (!$downloadRetry); } # # Process data and report # skipDownload: # # If we were requested to only download data, # we are now complete # goto finalize if ($opt->{'download-only'}); # # Start at the start # print (STDERR "Processing data and creating XMLTV output\n") if (!$quiet); # # Create some mappings for processing programs # # (Known) Schedules Direct cast roles and XMLTV map # (this map likely needs review and correction) my $castMap = { 'Actor' => { 'role' => 'actor' }, 'Self' => { 'role' => 'actor', 'self' => 1 }, 'Voice' => { 'role' => 'actor' }, 'Guest Star' => { 'role' => 'actor', 'guest' => 1 }, 'Guest Voice' => { 'role' => 'actor', 'guest' => 1 }, 'Athlete' => { 'role' => 'guest' }, 'Correspondent' => { 'role' => 'guest' }, 'Contestant' => { 'role' => 'guest' }, 'Guest' => { 'role' => 'guest' }, 'Musicial Guest' => { 'role' => 'guest' }, 'Music Performer' => { 'role' => 'guest' }, 'Anchor' => { 'role' => 'presenter' }, 'Host' => { 'role' => 'presenter' }, 'Narrator' => { 'role' => 'presenter' }, 'Judge' => { 'role' => 'presenter' } }; # (Known) Schedules Direct crew roles and XMLTV map # for those XMLTV roles we will use (there is no # XMLTV role for make up artist, for example) # (this map likely needs review and correction) my $crewMap = { 'Adaptation' => { 'role' => 'writer' }, 'Co-Screenwriter' => { 'role' => 'writer' }, 'Co-Writer' => { 'role' => 'writer' }, 'Creator' => { 'role' => 'writer' }, 'Film Consultant' => { 'role' => 'writer' }, 'Screen Story' => { 'role' => 'writer' }, 'Screenwriter' => { 'role' => 'writer' }, 'Script' => { 'role' => 'writer' }, 'Script Editor' => { 'role' => 'writer' }, 'Story Supervisor' => { 'role' => 'writer' }, 'Story' => { 'role' => 'writer' }, 'Writer' => { 'role' => 'writer' }, 'Writer (Adaptation)' => { 'role' => 'writer' }, 'Writer (Additional Dialogue)' => { 'role' => 'writer' }, 'Writer (Autobiography)' => { 'role' => 'writer' }, 'Writer (Book)' => { 'role' => 'writer' }, 'Writer (Characters)' => { 'role' => 'writer' }, 'Writer (Comic Book)' => { 'role' => 'writer' }, 'Writer (Continuity)' => { 'role' => 'writer' }, 'Writer (Dialogue)' => { 'role' => 'writer' }, 'Writer (Earlier Screenplay)' => { 'role' => 'writer' }, 'Writer (Idea)' => { 'role' => 'writer' }, 'Writer (Miniseries)' => { 'role' => 'writer' }, 'Writer (Narration)' => { 'role' => 'writer' }, 'Writer (Novel)' => { 'role' => 'writer' }, 'Writer (Opera)' => { 'role' => 'writer' }, 'Writer (Original Film)' => { 'role' => 'writer' }, 'Writer (Original Screenplay)' => { 'role' => 'writer' }, 'Writer (Play)' => { 'role' => 'writer' }, 'Writer (Poem)' => { 'role' => 'writer' }, 'Writer (Scenario)' => { 'role' => 'writer' }, 'Writer (Screen Story)' => { 'role' => 'writer' }, 'Writer (Screenplay)' => { 'role' => 'writer' }, 'Writer (Screenplay and Dialogue)' => { 'role' => 'writer' }, 'Writer (Screenplay and Novel)' => { 'role' => 'writer' }, 'Writer (Script)' => { 'role' => 'writer' }, 'Writer (Short Story)' => { 'role' => 'writer' }, 'Writer (Stage Musical)' => { 'role' => 'writer' }, 'Writer (Story)' => { 'role' => 'writer' }, 'Writer (Story and Screenplay)' => { 'role' => 'writer' }, 'Writer (Teleplay)' => { 'role' => 'writer' }, 'Writer (Television Series)' => { 'role' => 'writer' }, 'Writer (Treatment)' => { 'role' => 'writer' }, 'Action Director' => { 'role' => 'director' }, 'Animation Director' => { 'role' => 'director' }, 'Art Direction' => { 'role' => 'director' }, 'Art Director' => { 'role' => 'director' }, 'Artistic Director' => { 'role' => 'director' }, 'Assistant Art Director' => { 'role' => 'director' }, 'Assistant Director' => { 'role' => 'director' }, 'Associate Art Direction' => { 'role' => 'director' }, 'Associate Director' => { 'role' => 'director' }, 'Casting Director' => { 'role' => 'director' }, 'Cinematographer' => { 'role' => 'director' }, 'Co-Art Director' => { 'role' => 'director' }, 'Co-Director' => { 'role' => 'director' }, 'Creative Director' => { 'role' => 'director' }, 'Dance Director' => { 'role' => 'director' }, 'Director' => { 'role' => 'director' }, 'Director of Cinematography' => { 'role' => 'director' }, 'Director of Photography' => { 'role' => 'director' }, 'First Assistant Director' => { 'role' => 'director' }, 'Key Second Asst. Director' => { 'role' => 'director' }, 'Managing Technical Director' => { 'role' => 'director' }, 'Musical Director' => { 'role' => 'director' }, 'Music Director' => { 'role' => 'director' }, 'Recording Director' => { 'role' => 'director' }, 'Second Assistant Director' => { 'role' => 'director' }, 'Second Second Assistant Director' => { 'role' => 'director' }, 'Second Unit Director' => { 'role' => 'director' }, 'Senior Art Director' => { 'role' => 'director' }, 'Set Director' => { 'role' => 'director' }, 'Stunt Action Director' => { 'role' => 'director' }, 'Supervising Art Direction' => { 'role' => 'director' }, 'Third Assistant Director' => { 'role' => 'director' }, 'Trainee Assistant Director' => { 'role' => 'director' }, 'Unit Director' => { 'role' => 'director' }, 'Voice Director' => { 'role' => 'director' }, 'Wardrobe Director' => { 'role' => 'director' }, 'Additional Editor' => { 'role' => 'editor' }, 'Assistant Dialogue Editor' => { 'role' => 'editor' }, 'Assistant Editor' => { 'role' => 'editor' }, 'Assistant Sound Editor' => { 'role' => 'editor' }, 'Associate Film Editor' => { 'role' => 'editor' }, 'Background Sound Editor' => { 'role' => 'editor' }, 'Co-Editor' => { 'role' => 'editor' }, 'Dialogue Editor' => { 'role' => 'editor' }, 'Editing' => { 'role' => 'editor' }, 'Editor' => { 'role' => 'editor' }, 'Film Editing' => { 'role' => 'editor' }, 'Film Editor' => { 'role' => 'editor' }, 'Foley Editor' => { 'role' => 'editor' }, 'Music Editor' => { 'role' => 'editor' }, 'Sound Editor' => { 'role' => 'editor' }, 'Sound Effects Editor' => { 'role' => 'editor' }, 'Supervising ADR Editor' => { 'role' => 'editor' }, 'Supervising Editor' => { 'role' => 'editor' }, 'Supervising Foley Editor' => { 'role' => 'editor' }, 'Supervising Sound Editor' => { 'role' => 'editor' }, 'Animation Producer' => { 'role' => 'producer' }, 'Assistant Producer' => { 'role' => 'producer' }, 'Associate Executive Producer' => { 'role' => 'producer' }, 'Associate Producer' => { 'role' => 'producer' }, 'Chief Producer' => { 'role' => 'producer' }, 'Co-Associate Producer' => { 'role' => 'producer' }, 'Co-Executive Producer' => { 'role' => 'producer' }, 'Consulting Producer' => { 'role' => 'producer' }, 'Coordinating Producer' => { 'role' => 'producer' }, 'Co-Producer' => { 'role' => 'producer' }, 'Executive Co-Producer' => { 'role' => 'producer' }, 'Executive in Charge of Production' => { 'role' => 'producer' }, 'Executive Music Producer' => { 'role' => 'producer' }, 'Executive Producer' => { 'role' => 'producer' }, 'Line Producer' => { 'role' => 'producer' }, 'Location Producer' => { 'role' => 'producer' }, 'Makeup Effects Producer' => { 'role' => 'producer' }, 'Music Producer' => { 'role' => 'producer' }, 'Producer' => { 'role' => 'producer' }, 'Score Producer' => { 'role' => 'producer' }, 'Senior Producer' => { 'role' => 'producer' }, 'Special Effects Makeup Producer' => { 'role' => 'producer' }, 'Supervising Producer' => { 'role' => 'producer' }, 'Visual Effects Producer' => { 'role' => 'producer' }, 'Additional Music' => { 'role' => 'composer' }, 'Composer' => { 'role' => 'composer' }, 'Lyricist' => { 'role' => 'composer' }, 'Lyrics' => { 'role' => 'composer' }, 'Music' => { 'role' => 'composer' }, 'Music Arranger' => { 'role' => 'composer' }, 'Music Score' => { 'role' => 'composer' }, 'Music Supervisor' => { 'role' => 'composer' }, 'Music Theme' => { 'role' => 'composer' }, 'Non-Original Music' => { 'role' => 'composer' }, 'Original Music' => { 'role' => 'composer' }, 'Original Music and Songs' => { 'role' => 'composer' }, 'Original Score' => { 'role' => 'composer' }, 'Original Song' => { 'role' => 'composer' }, 'Original Songs' => { 'role' => 'composer' }, 'Original Theme' => { 'role' => 'composer' }, 'Songs' => { 'role' => 'composer' }, # # The following crew roles at Schedules Direct # have no clear XMLTV equivalent (suggestions # encouraged). We list them here so it will # be easier to identify new roles in the future. # 'Animation Supervisor' => { 'role' => 'undefined' }, 'Animator' => { 'role' => 'undefined' }, 'Art Department' => { 'role' => 'undefined' }, 'Assistant Makeup Artist' => { 'role' => 'undefined' }, 'Assistant Production Manager' => { 'role' => 'undefined' }, 'Associate Costume Designer' => { 'role' => 'undefined' }, 'Associate Set Decorator' => { 'role' => 'undefined' }, 'Athlete' => { 'role' => 'undefined' }, 'Background Music' => { 'role' => 'undefined' }, 'Boom Operator' => { 'role' => 'undefined' }, 'Cameraman' => { 'role' => 'undefined' }, 'Camera Operator' => { 'role' => 'undefined' }, 'Casting' => { 'role' => 'undefined' }, 'Characters' => { 'role' => 'undefined' }, 'Chief Hair Stylist' => { 'role' => 'undefined' }, 'Chief Makeup Artist' => { 'role' => 'undefined' }, 'Choreographer' => { 'role' => 'undefined' }, 'Cinematography' => { 'role' => 'undefined' }, 'Conductor' => { 'role' => 'undefined' }, 'Construction Coordinator' => { 'role' => 'undefined' }, 'Co-Production Designer' => { 'role' => 'undefined' }, 'Costume Design' => { 'role' => 'undefined' }, 'Costume Designer' => { 'role' => 'undefined' }, 'Costume Supervisor' => { 'role' => 'undefined' }, 'Creative Consultant' => { 'role' => 'undefined' }, 'Design' => { 'role' => 'undefined' }, 'Dialogue' => { 'role' => 'undefined' }, 'Executive Assistant' => { 'role' => 'undefined' }, 'Foley Artist' => { 'role' => 'undefined' }, 'Graphic Artist' => { 'role' => 'undefined' }, 'Graphic Design' => { 'role' => 'undefined' }, 'Graphic Designer' => { 'role' => 'undefined' }, 'Graphics' => { 'role' => 'undefined' }, 'Hair Designer' => { 'role' => 'undefined' }, 'Hair Stylist Supervisor' => { 'role' => 'undefined' }, 'Hair Stylist' => { 'role' => 'undefined' }, 'Key Grip' => { 'role' => 'undefined' }, 'Key Hair Stylist' => { 'role' => 'undefined' }, 'Key Makeup Artist' => { 'role' => 'undefined' }, 'Lighting' => { 'role' => 'undefined' }, 'Location Manager' => { 'role' => 'undefined' }, 'Makeup' => { 'role' => 'undefined' }, 'Makeup Artist' => { 'role' => 'undefined' }, 'Makeup Assistant' => { 'role' => 'undefined' }, 'Makeup Department Head' => { 'role' => 'undefined' }, 'Makeup Designer' => { 'role' => 'undefined' }, 'Makeup Supervisor' => { 'role' => 'undefined' }, 'Martial Arts Advisor' => { 'role' => 'undefined' }, 'Martial Arts Choreographer' => { 'role' => 'undefined' }, 'Mixing' => { 'role' => 'undefined' }, 'Music Mixer' => { 'role' => 'undefined' }, 'Music Recordist' => { 'role' => 'undefined' }, 'Original Concept' => { 'role' => 'undefined' }, 'Photographer' => { 'role' => 'undefined' }, 'Post-Production' => { 'role' => 'undefined' }, 'Post-Production Manager' => { 'role' => 'undefined' }, 'Post-Production Supervisor' => { 'role' => 'undefined' }, 'Production Assistant' => { 'role' => 'undefined' }, 'Production Coordinator' => { 'role' => 'undefined' }, 'Production Designer' => { 'role' => 'undefined' }, 'Production Design' => { 'role' => 'undefined' }, 'Production Executive' => { 'role' => 'undefined' }, 'Production Manager' => { 'role' => 'undefined' }, 'Production Sound Editor' => { 'role' => 'undefined' }, 'Production Sound Mixer' => { 'role' => 'undefined' }, 'Production Supervisor' => { 'role' => 'undefined' }, 'Property Master' => { 'role' => 'undefined' }, 'Recording Engineer' => { 'role' => 'undefined' }, 'Recording Supervisor' => { 'role' => 'undefined' }, 'Researcher' => { 'role' => 'undefined' }, 'Scene Designer' => { 'role' => 'undefined' }, 'Scenic Artist' => { 'role' => 'undefined' }, 'Score Mixer' => { 'role' => 'undefined' }, 'Screen Story Writer' => { 'role' => 'undefined' }, 'Script Supervisor' => { 'role' => 'undefined' }, 'Set Construction' => { 'role' => 'undefined' }, 'Set Decoration' => { 'role' => 'undefined' }, 'Set Designer' => { 'role' => 'undefined' }, 'Set Dresser' => { 'role' => 'undefined' }, 'Singer' => { 'role' => 'undefined' }, 'Sound' => { 'role' => 'undefined' }, 'Sound Assistant' => { 'role' => 'undefined' }, 'Sound Consultant' => { 'role' => 'undefined' }, 'Sound Designer' => { 'role' => 'undefined' }, 'Sound Effects' => { 'role' => 'undefined' }, 'Sound Engineer' => { 'role' => 'undefined' }, 'Sound Mixer' => { 'role' => 'undefined' }, 'Sound Recordist' => { 'role' => 'undefined' }, 'Sound Re-Recording Mixer' => { 'role' => 'undefined' }, 'Sound Supervisor' => { 'role' => 'undefined' }, 'Sound Technician' => { 'role' => 'undefined' }, 'Special Effects' => { 'role' => 'undefined' }, 'Special Effects Coordinator' => { 'role' => 'undefined' }, 'Special Effects Supervisor' => { 'role' => 'undefined' }, 'Special Makeup Effects Artist' => { 'role' => 'undefined' }, 'Special Makeup Effects' => { 'role' => 'undefined' }, 'Special Photographic Effects' => { 'role' => 'undefined' }, 'Storyboard' => { 'role' => 'undefined' }, 'Storyboard Artist' => { 'role' => 'undefined' }, 'Storyboard Supervisor' => { 'role' => 'undefined' }, 'Stunt Choreographer' => { 'role' => 'undefined' }, 'Stunt Coordinator' => { 'role' => 'undefined' }, 'Stunt Supervisor' => { 'role' => 'undefined' }, 'Stunts' => { 'role' => 'undefined' }, 'Supervising Animator' => { 'role' => 'undefined' }, 'Unit Manager' => { 'role' => 'undefined' }, 'Unit Production' => { 'role' => 'undefined' }, 'Unit Production Manager' => { 'role' => 'undefined' }, 'Visual Effects' => { 'role' => 'undefined' }, 'Visual Effects Coordinator' => { 'role' => 'undefined' }, 'Visual Effects Designer' => { 'role' => 'undefined' }, 'Visual Effects Supervisor' => { 'role' => 'undefined' }, 'Voice-Over' => { 'role' => 'undefined' }, 'Wardrobe' => { 'role' => 'undefined' } }; my $w = XML::Writer->new( 'ENCODING' => 'UTF-8', 'DATA_MODE' => 1, 'DATA_INDENT' => 1, 'UNSAFE' => (!$debug) ); $w->xmlDecl('UTF-8'); $w->comment($SD_COMMENT); $w->doctype( 'tv', undef, 'xmltv.dtd' ); $w->startTag('tv', 'generator-info-name' => $SCRIPT_NAME, 'generator-info-url' => $SCRIPT_URL, 'source-info-name' => $SD_DESC, 'source-info-url' => $SD_SITEURL ); my $channelsWritten = channelWriter($conf->{'lineup'}, $w); print (STDERR " $channelsWritten channels processed\n") if (!$quiet); # # Select out schedules/programs # # This select has (the only) sqlite specific SQL in it # to deal with datetime processing. Perl performance # for operating on datetime is poor (it is arguably # reasonable given the complexity of datatime operations) # so we let sqlite do the work for us. It is not # desirable, but when you get back 40-50% of the cpu # it is a necessary compromise # $sql = "select schedules.station, schedules.starttime, schedules.duration, schedules.program, schedules.details, programs.details, strftime('%Y%m%d%H%M%S', schedules.starttime), strftime('%Y%m%d%H%M%S', datetime(schedules.starttime, '+' || schedules.duration || ' seconds')), stations.details, supplemental.details from schedules as schedules left join programs as programs on programs.program = schedules.program left join stations as stations on stations.station = schedules.station left join programs as supplemental on programs.program_supplemental = supplemental.program where schedules.station in (select distinct stations.station from stations as stations where stations.station in ( select distinct channels.station from channels as channels where channels.lineup in ( " . join(', ', ('?') x scalar(@{$conf->{'lineup'}})) . " ) and channels.selected = 1)) AND schedules.day >= ? and schedules.day < ? order by schedules.station, schedules.starttime"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } # # Determine our start and end days # my $startDay = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'}); my $endDay = DateTime->now(time_zone => 'UTC')->add(days => $opt->{'offset'})->add(days => $opt->{'days'}); $param = 1; for (my $i=0; $i < scalar(@{$conf->{'lineup'}}); $i++) { $sth->bind_param( $param, @{$conf->{'lineup'}}[$i], SQL_VARCHAR); $param++; } $sth->bind_param( $param, DateTime::Format::SQLite->format_date($startDay), SQL_DATE ); $param++; $sth->bind_param( $param, DateTime::Format::SQLite->format_date($endDay), SQL_DATE ); $param++; $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_DATETIME ); $sth->bind_col( 3, undef, SQL_INTEGER ); $sth->bind_col( 4, undef, SQL_VARCHAR ); $sth->bind_col( 5, undef, SQL_VARCHAR ); $sth->bind_col( 6, undef, SQL_VARCHAR ); $sth->bind_col( 7, undef, SQL_VARCHAR ); $sth->bind_col( 8, undef, SQL_VARCHAR ); $sth->bind_col( 9, undef, SQL_VARCHAR ); $sth->bind_col(10, undef, SQL_VARCHAR ); my $programsWritten = 0; while (my $r = $sth->fetchrow_arrayref()) { my $sID = $r->[0]; # Note that we should legitmately parse the datetime here, but # the performance absolutely sucks, so we let sqlite do this # my $startTime = DateTime::Format::SQLite->parse_datetime($r->[1]); # my $endTime = $startTime->clone()->add(seconds => $r->[2]); my $pID = $r->[3]; my $scheduleDetails = eval { $JSON->decode($r->[4]) } || {}; my $programDetails = eval { $JSON->decode($r->[5]) } || {}; my $stationDetails = eval { $JSON->decode($r->[8]) } || {};; my $supplementalDetails = eval { $JSON->decode($r->[9]) } || {};; $w->startTag('programme', 'channel' => generateRFC2838($sID), 'start' => "$r->[6] +0000", 'stop' => "$r->[7] +0000"); # Mandatory title array should (must?) contain title120, but may # contain others? if (defined($programDetails->{'titles'})) { foreach my $title(@{$programDetails->{'titles'}}) { if (defined($title->{'title120'})) { $w->dataElement('title', $title->{'title120'}); } } } elsif (defined($supplementalDetails->{'titles'})) { foreach my $title(@{$supplementalDetails->{'titles'}}) { if (defined($title->{'title120'})) { $w->dataElement('title', $title->{'title120'}); } } } if (defined($programDetails->{'episodeTitle150'})) { $w->dataElement('sub-title', $programDetails->{'episodeTitle150'}); } elsif (defined($supplementalDetails->{'episodeTitle150'})) { $w->dataElement('sub-title', $supplementalDetails->{'episodeTitle150'}); } # Choose the "best" (i.e. longer) description if available if (defined($programDetails->{'descriptions'}->{'description1000'})) { foreach my $d(@{$programDetails->{'descriptions'}->{'description1000'}}) { my $lang = $d->{'descriptionLanguage'}; my $desc = $d->{'description'}; next if ((!defined($lang) || (!defined($desc)))); $w->dataElement('desc', $desc, 'lang' => $lang); } } elsif (defined($programDetails->{'descriptions'}->{'description100'})) { foreach my $d(@{$programDetails->{'descriptions'}->{'description100'}}) { my $lang = $d->{'descriptionLanguage'}; my $desc = $d->{'description'}; next if ((!defined($lang) || (!defined($desc)))); $w->dataElement('desc', $desc, 'lang' => $lang); } } elsif (defined($supplementalDetails->{'descriptions'}->{'description1000'})) { foreach my $d(@{$supplementalDetails->{'descriptions'}->{'description1000'}}) { my $lang = $d->{'descriptionLanguage'}; my $desc = $d->{'description'}; next if ((!defined($lang) || (!defined($desc)))); $w->dataElement('desc', $desc, 'lang' => $lang); } } elsif (defined($supplementalDetails->{'descriptions'}->{'description100'})) { foreach my $d(@{$supplementalDetails->{'descriptions'}->{'description100'}}) { my $lang = $d->{'descriptionLanguage'}; my $desc = $d->{'description'}; next if ((!defined($lang) || (!defined($desc)))); $w->dataElement('desc', $desc, 'lang' => $lang); } } # XMLTV roles for this program my $roles = { 'director' => {}, 'actor' => {}, 'writer' => {}, 'adapter' => {}, 'producer' => {}, 'composer' => {}, 'editor' => {}, 'presenter' => {}, 'commentator' => {}, 'guest' => {} }; # XMLTV dtd requires us to collect the various cast and # crew items in order to process in the dtd order. In # addition, the dtd specifies that the order of the # roles is meaningful (first billing should come first). # All too often the supplemental (SHow) has more # detailed cast/crew data that the program (EPisode) # itself, and in particular, the character. if (defined($programDetails->{'cast'})) { foreach my $cast(@{$programDetails->{'cast'}}) { my $castAttributes = $castMap->{$cast->{'role'}}; next if (!defined($castAttributes)); my $role = $castAttributes->{'role'}; next if (!defined($role)); addRole($roles, $role, $cast->{'name'}, $cast->{'billingOrder'}, $cast->{'characterName'}, $castAttributes); } } if (defined($programDetails->{'crew'})) { foreach my $crew(@{$programDetails->{'crew'}}) { my $crewAttributes = $crewMap->{$crew->{'role'}}; next if (!defined($crewAttributes)); my $role = $crewAttributes->{'role'}; next if (!defined($role)); addRole($roles, $role, $crew->{'name'}, $crew->{'billingOrder'}, undef, $crewAttributes); } } if (defined($supplementalDetails->{'cast'})) { foreach my $cast(@{$supplementalDetails->{'cast'}}) { my $castAttributes = $castMap->{$cast->{'role'}}; next if (!defined($castAttributes)); my $role = $castAttributes->{'role'}; next if (!defined($role)); addRole($roles, $role, $cast->{'name'}, '100' . $cast->{'billingOrder'}, $cast->{'characterName'}, $castAttributes); } } if (defined($supplementalDetails->{'crew'})) { foreach my $crew(@{$supplementalDetails->{'crew'}}) { my $crewAttributes = $crewMap->{$crew->{'role'}}; next if (!defined($crewAttributes)); my $role = $crewAttributes->{'role'}; next if (!defined($role)); addRole($roles, $role, $crew->{'name'}, '100' . $crew->{'billingOrder'}, undef, $crewAttributes); } } $w->startTag('credits'); foreach my $role('director', 'actor', 'writer', 'adapter', 'producer', 'composer', 'editor', 'presenter', 'commentator', 'guest') { foreach my $person(sort {$roles->{$role}->{$a}->{'order'} <=> $roles->{$role}->{$b}->{'order'}} (keys %{$roles->{$role}})) { my $attributes = $roles->{$role}->{$person}->{'attributes'}; # Only actors have characters and guest/self attributes if ($role eq 'actor') { my $extendedAttributes = {}; if (($attributes->{'guest'}) && (!exists($GRABBER_FIXUPS->{'NO_ACTOR_GUEST_ATTRIBUTE'}))) { $extendedAttributes->{'guest'} = 'yes'; } if (0 == scalar(@{$roles->{$role}->{$person}->{'character'}})) { if ($attributes->{'self'}) { $extendedAttributes->{'role'} = 'Self'; } $w->dataElement($role, $person, %{$extendedAttributes}); } else { foreach my $character(@{$roles->{$role}->{$person}->{'character'}}) { $w->dataElement($role, $person, 'role' => $character, %{$extendedAttributes}); } } } else { $w->dataElement($role, $person); } } } $w->endTag('credits'); # Only movies (likely) have a date if (defined($programDetails->{'movie'}->{'year'})) { $w->dataElement('date', $programDetails->{'movie'}->{'year'}); } elsif (defined($supplementalDetails->{'movie'}->{'year'})) { $w->dataElement('date', $supplementalDetails->{'movie'}->{'year'}); } if (defined($conf->{'mythtv-categories'}->[0]) && ($conf->{'mythtv-categories'}->[0] eq 'enabled')) { # For MythTV, we need to specify the first category # in the xmltv file as one of movie, series, sports, # or tvshow. We can derive that from the entityType. # If the station is a radio station, we do not add # tvshow, but add radio (because the first category # is not processed in the usual way). my $radioStation = 0; if (defined($stationDetails->{'isRadioStation'})) { $radioStation = $stationDetails->{'isRadioStation'}; } if (defined($programDetails->{'entityType'})) { my $entityType = $programDetails->{'entityType'}; if ($entityType eq 'Movie') { $w->dataElement('category', 'movie'); } elsif ($entityType eq 'Sports') { $w->dataElement('category', 'sports'); } elsif ($entityType eq 'Episode') { $w->dataElement('category', 'series'); } else # Should be Show { my $showType = ''; if (defined($programDetails->{'showType'})) { $showType = $programDetails->{'showType'}; } elsif (defined($supplementalDetails->{'showType'})) { $showType = $supplementalDetails->{'showType'}; } if (($showType eq 'Feature Film') || ($showType eq 'Short Film') || ($showType eq 'TV Movie')) { $w->dataElement('category', 'movie'); } elsif (($showType eq 'Sports event') || ($showType eq 'Sports non-event')) { $w->dataElement('category', 'sports'); } elsif (($showType eq 'Series') || ($showType eq 'Miniseries')) { $w->dataElement('category', 'series'); } else { if ($radioStation) { $w->dataElement('category', 'radio'); } else { $w->dataElement('category', 'tvshow'); } } } } else # entityType is supposed to be manditory, but.... { if ($radioStation) { $w->dataElement('category', 'radio'); } else { $w->dataElement('category', 'tvshow'); } } } # XMLTV categories are somewhat arbitrary. We collect the # genres, showType, and entityType as categories. There is # no order implication in the XMLTV dtd for categories, # but at least one well known app cares about the order, # so we try to be accomodating, and priorize program # over supplemental data. my $categories = {}; my $categorynum = 0; if (defined($programDetails->{'genres'})) { foreach my $genre(@{$programDetails->{'genres'}}) { $categories->{$genre} = $categorynum++ if (!defined($categories->{$genre})); } } if (defined($supplementalDetails->{'genres'})) { foreach my $genre(@{$supplementalDetails->{'genres'}}) { $categories->{$genre} = $categorynum++ if (!defined($categories->{$genre})); } } if (defined($programDetails->{'showType'})) { $categories->{$programDetails->{'showType'}} = $categorynum++ if (!defined($categories->{$programDetails->{'showType'}})); } if (defined($supplementalDetails->{'showType'})) { $categories->{$supplementalDetails->{'showType'}} = $categorynum++ if (!defined($categories->{$supplementalDetails->{'showType'}})); } if (defined($programDetails->{'entityType'})) { $categories->{$programDetails->{'entityType'}} = $categorynum++ if (!defined($categories->{$programDetails->{'entityType'}})); } if (defined($supplementalDetails->{'entityType'})) { $categories->{$supplementalDetails->{'entityType'}} = $categorynum++ if (!defined($categories->{$supplementalDetails->{'entityType'}})); } foreach my $category (sort {$categories->{$a} <=> $categories->{$b}} (keys %{$categories})) { $w->dataElement('category', $category); } # MythTV does not currently have a concept of keywords, # so this is output is likely meaningless. Perhaps a # future enhancement (a new "programkeywords" table?), # or keywords should be added as categories? Some of # the keywords might make usable categories. There # is no order implication for keywords in the XMLTV dtd. my $keywords = {}; if (defined($programDetails->{'keyWords'})) { foreach my $keyCat(keys %{$programDetails->{'keyWords'}}) { foreach my $kw(@{$programDetails->{'keyWords'}->{$keyCat}}) { $keywords->{$kw} = 1 } } } if (defined($supplementalDetails->{'keyWords'})) { foreach my $keyCat(keys %{$supplementalDetails->{'keyWords'}}) { foreach my $kw(@{$supplementalDetails->{'keyWords'}->{$keyCat}}) { $keywords->{$kw} = 1 } } } foreach my $keyword (sort keys %{$keywords}) { $w->dataElement('keyword', $keyword); } if (defined($programDetails->{'duration'})) { $w->dataElement('length', $programDetails->{'duration'}, 'units' => 'seconds'); } elsif (defined($supplementalDetails->{'duration'})) { $w->dataElement('length', $supplementalDetails->{'duration'}, 'units' => 'seconds'); } if (defined($programDetails->{'episodeImage'}) && defined($programDetails->{'episodeImage'}->{'uri'})) { my $url = $SD->uriResolve($programDetails->{'episodeImage'}->{'uri'}, '/image'); if (defined($programDetails->{'episodeImage'}->{'width'}) && defined($programDetails->{'episodeImage'}->{'height'})) { $w->emptyTag('icon', 'src' => $url, 'width' => $programDetails->{'episodeImage'}->{'width'}, 'height' => $programDetails->{'episodeImage'}->{'height'}); } else { $w->emptyTag('icon', 'src' => $url); } } elsif (defined($supplementalDetails->{'episodeImage'}) && defined($supplementalDetails->{'episodeImage'}->{'uri'})) { my $url = $SD->uriResolve($supplementalDetails->{'episodeImage'}->{'uri'}, '/image'); if (defined($supplementalDetails->{'episodeImage'}->{'width'}) && defined($supplementalDetails->{'episodeImage'}->{'height'})) { $w->emptyTag('icon', 'src' => $url, 'width' => $supplementalDetails->{'episodeImage'}->{'width'}, 'height' => $supplementalDetails->{'episodeImage'}->{'height'}); } else { $w->emptyTag('icon', 'src' => $url); } } if (defined($programDetails->{'officialURL'})) { $w->dataElement('url', $programDetails->{'officialURL'}); } elsif (defined($supplementalDetails->{'officialURL'})) { $w->dataElement('url', $supplementalDetails->{'officialURL'}); } my $prodid = $pID; if (length($prodid) == 14) { $prodid = substr($prodid, 0, 10) . '.' . substr($prodid, 10, 4); $w->dataElement('episode-num', $prodid, 'system' => 'dd_progid' ); } # Season/Episode numbering is "special" as SHows and # EPisodes use slightly different interpretations of # the exact same terms. my $season = ''; my $episode = ''; my $part = ''; my $programEpisode; my $programTotalEpisodes; my $programSeason; my $showSeason; my $showEpisode; my $showTotalEpisodes; my $showTotalSeasons; my $showingPart; my $showingTotalParts; my $TVDBseriesID; my $TVDBepisodeID; my $TVmazeSeason; my $TVmazeEpisode; my $TVmazeURL; if (defined($supplementalDetails->{'metadata'})) { foreach my $meta(@{$supplementalDetails->{'metadata'}}) { if (defined($meta->{'Gracenote'})) { if ((defined($supplementalDetails->{'programID'})) && ('SH' eq substr($supplementalDetails->{'programID'}, 0, 2))) { $showSeason = $meta->{'Gracenote'}->{'season'}; $showEpisode = $meta->{'Gracenote'}->{'episode'}; $showTotalSeasons = $meta->{'Gracenote'}->{'totalSeasons'}; $showTotalEpisodes = $meta->{'Gracenote'}->{'totalEpisodes'}; } } if (defined($meta->{'TheTVDB'})) { if ((defined($meta->{'TheTVDB'}->{'episodeID'})) && (looks_like_number($meta->{'TheTVDB'}->{'episodeID'})) && ($meta->{'TheTVDB'}->{'episodeID'} > 0)) { $TVDBepisodeID = 0 + $meta->{'TheTVDB'}->{'episodeID'}; } if ((defined($meta->{'TheTVDB'}->{'seriesID'})) && (looks_like_number($meta->{'TheTVDB'}->{'seriesID'})) && ($meta->{'TheTVDB'}->{'seriesID'} > 0)) { $TVDBseriesID = 0 + $meta->{'TheTVDB'}->{'seriesID'}; } } if (defined($meta->{'TVmaze'})) { if ((defined($meta->{'TVmaze'}->{'episode'})) && (looks_like_number($meta->{'TVmaze'}->{'episode'})) && ($meta->{'TVmaze'}->{'episode'} > 0)) { $TVmazeEpisode = 0 + $meta->{'TVmaze'}->{'episode'}; } if ((defined($meta->{'TVmaze'}->{'season'})) && (looks_like_number($meta->{'TVmaze'}->{'season'})) && ($meta->{'TVmaze'}->{'season'} > 0)) { $TVmazeSeason = 0 + $meta->{'TVmaze'}->{'season'}; } if ((defined($meta->{'TVmaze'}->{'url'})) && ($meta->{'TVmaze'}->{'url'} ne '')) { $TVmazeURL = $meta->{'TVmaze'}->{'url'}; } } } } if (defined($programDetails->{'metadata'})) { foreach my $meta(@{$programDetails->{'metadata'}}) { if (defined($meta->{'Gracenote'})) { if (substr($pID, 0, 2) eq 'SH') { $showSeason = $meta->{'Gracenote'}->{'season'}; $showEpisode = $meta->{'Gracenote'}->{'episode'}; $showTotalSeasons = $meta->{'Gracenote'}->{'totalSeasons'}; $showTotalEpisodes = $meta->{'Gracenote'}->{'totalEpisodes'}; } else { $programSeason = $meta->{'Gracenote'}->{'season'}; $programEpisode = $meta->{'Gracenote'}->{'episode'}; $programTotalEpisodes = $meta->{'Gracenote'}->{'totalEpisodes'}; } } if (defined($meta->{'TheTVDB'})) { if ((defined($meta->{'TheTVDB'}->{'episodeID'})) && (looks_like_number($meta->{'TheTVDB'}->{'episodeID'})) && ($meta->{'TheTVDB'}->{'episodeID'} > 0)) { $TVDBepisodeID = 0 + $meta->{'TheTVDB'}->{'episodeID'}; } if ((defined($meta->{'TheTVDB'}->{'seriesID'})) && (looks_like_number($meta->{'TheTVDB'}->{'seriesID'})) && ($meta->{'TheTVDB'}->{'seriesID'} > 0)) { $TVDBseriesID = 0 + $meta->{'TheTVDB'}->{'seriesID'}; } } if (defined($meta->{'TVmaze'})) { if ((defined($meta->{'TVmaze'}->{'episode'})) && (looks_like_number($meta->{'TVmaze'}->{'episode'})) && ($meta->{'TVmaze'}->{'episode'} > 0)) { $TVmazeEpisode = 0 + $meta->{'TVmaze'}->{'episode'}; } if ((defined($meta->{'TVmaze'}->{'season'})) && (looks_like_number($meta->{'TVmaze'}->{'season'})) && ($meta->{'TVmaze'}->{'season'} > 0)) { $TVmazeSeason = 0 + $meta->{'TVmaze'}->{'season'}; } if ((defined($meta->{'TVmaze'}->{'url'})) && ($meta->{'TVmaze'}->{'url'} ne '')) { $TVmazeURL = $meta->{'TVmaze'}->{'url'}; } } } } if (defined($scheduleDetails->{'multipart'})) { $showingPart = $scheduleDetails->{'multipart'}->{'partNumber'}; $showingTotalParts = $scheduleDetails->{'multipart'}->{'totalParts'}; } $programSeason = $showSeason if (!defined($programSeason)); $programEpisode = $showEpisode if (!defined($programEpisode)); $showTotalSeasons = undef if (exists($GRABBER_FIXUPS->{'NO_XMLTV_NS_TOTAL_SEASONS'})); $season = generateXMLTV_NS($programSeason, $showTotalSeasons); $episode = generateXMLTV_NS($programEpisode, $programTotalEpisodes); $part = generateXMLTV_NS($showingPart, $showingTotalParts); if (($season ne '') || ($episode ne '') || ($part ne '')) { $w->dataElement('episode-num', " $season . $episode . $part ", 'system' => 'xmltv_ns'); } # # Potentionally need to know if this is a new showing # in the extra metadata section, and again for the # previously shown determination # my $newShowing = 0; $newShowing = $scheduleDetails->{'new'} if (defined($scheduleDetails->{'new'})); # # Emit 3rdparty metadata if not disabled # if ((!defined($conf->{'3rdparty-metadata'}->[0])) || ($conf->{'3rdparty-metadata'}->[0] ne 'disabled')) { if (defined($TVDBepisodeID)) { $w->dataElement('episode-num', "episode/" . $TVDBepisodeID, 'system' => 'thetvdb.com'); } if (defined($TVDBseriesID)) { $w->dataElement('episode-num', "series/" . $TVDBseriesID, 'system' => 'thetvdb.com'); } if (defined($TVmazeEpisode)) { $w->dataElement('episode-num', "episode/" . $TVmazeEpisode, 'system' => 'tvmaze.com'); } if (defined($TVmazeSeason)) { $w->dataElement('episode-num', "series/" . $TVmazeSeason, 'system' => 'tvmaze.com'); } if (defined($TVmazeURL)) { $w->dataElement('episode-num', "url/" . $TVmazeURL, 'system' => 'tvmaze.com'); } $w->dataElement('episode-num', "programID/$pID", 'system' => 'schedulesdirect.org' ); if (defined($programSeason)) { $w->dataElement('episode-num', "series/" . $programSeason, 'system' => 'schedulesdirect.org'); } if (defined($programEpisode)) { $w->dataElement('episode-num', "episode/" . $programEpisode, 'system' => 'schedulesdirect.org'); } if (defined($programDetails->{'resourceID'})) { $w->dataElement('episode-num', "resourceID/$programDetails->{'resourceID'}", 'system' => 'schedulesdirect.org'); } elsif (defined($supplementalDetails->{'resourceID'})) { $w->dataElement('episode-num', "resourceID/$supplementalDetails->{'resourceID'}", 'system' => 'schedulesdirect.org'); } if ($newShowing) { $w->dataElement('episode-num', "newEpisode/true", 'system' => 'schedulesdirect.org'); } if (defined($programDetails->{'originalAirDate'})) { my $originalAirDate = $programDetails->{'originalAirDate'}; my $d = substr($originalAirDate, 0, 4) . substr($originalAirDate, 5, 2) . substr($originalAirDate, 8, 2) . ' +0000'; $w->dataElement('episode-num', "originalAirDate/$d", 'system' => 'schedulesdirect.org'); } if (defined($programDetails->{'eventDetails'}) && (ref($programDetails->{'eventDetails'}) eq 'HASH')) { if (defined($programDetails->{'eventDetails'}->{'venue100'})) { $w->dataElement('episode-num', "eventVenue/$programDetails->{'eventDetails'}->{'venue100'}", 'system' => 'schedulesdirect.org'); } if (defined($programDetails->{'eventDetails'}->{'gameDate'})) { my $gameDate = $programDetails->{'eventDetails'}->{'gameDate'}; my $d = substr($gameDate, 0, 4) . substr($gameDate, 5, 2) . substr($gameDate, 8, 2) . ' +0000'; $w->dataElement('episode-num', "eventDate/$d", 'system' => 'schedulesdirect.org'); } if (defined($programDetails->{'eventDetails'}->{'teams'}) && (ref($programDetails->{'eventDetails'}->{'teams'}) eq 'ARRAY')) { foreach my $t(@{$programDetails->{'eventDetails'}->{'teams'}}) { if (ref($t) eq 'HASH') { if (defined($t->{'name'})) { if ((defined($t->{'isHome'})) && ($t->{'isHome'})) { $w->dataElement('episode-num', "eventHomeTeam/$t->{'name'}", 'system' => 'schedulesdirect.org'); } else { $w->dataElement('episode-num', "eventTeam/$t->{'name'}", 'system' => 'schedulesdirect.org'); } } } } } if (defined($programDetails->{'eventDetails'}->{'season'}) && (ref($programDetails->{'eventDetails'}->{'season'}) eq 'HASH')) { if (defined($programDetails->{'eventDetails'}->{'season'}->{'season'})) { $w->dataElement('episode-num', "eventSeason/$programDetails->{'eventDetails'}->{'season'}->{'season'}", 'system' => 'schedulesdirect.org'); } if (defined($programDetails->{'eventDetails'}->{'season'}->{'type'})) { $w->dataElement('episode-num', "eventSeasonType/$programDetails->{'eventDetails'}->{'season'}->{'type'}", 'system' => 'schedulesdirect.org'); } } } } if (defined($scheduleDetails->{'videoProperties'})) { my $videoHDTV = 0; my $videoUHDTV = 0; my $videoHDR = 0; foreach my $videoProperty(@{$scheduleDetails->{'videoProperties'}}) { $videoHDTV = 1 if ($videoProperty eq 'hdtv'); $videoUHDTV = 1 if ($videoProperty eq 'uhdtv'); $videoHDR = 1 if ($videoProperty eq 'hdr'); } if ($videoHDTV || $videoUHDTV || $videoHDR) { $w->startTag('video'); if ((defined($conf->{'extended-video-quality'}->[0])) && ($conf->{'extended-video-quality'}->[0] eq 'enabled')) { if ($videoHDR) # HDR is UHDTV, but not all UHDTV is HDR { $w->dataElement('quality', 'HDR'); } elsif ($videoUHDTV) { $w->dataElement('quality', 'UHDTV'); } else { $w->dataElement('quality', 'HDTV'); } } else { $w->dataElement('quality', 'HDTV'); } $w->endTag('video'); } } # XMLTV only supports one audio quality report, so we try # to determine the best available to report. We also need # to collect the closed caption information for future # reporting. my $audioHasCC = 0; # Need to carry forward my $audioHasSubtitle = 0; my $audioHasDVS = 0; my $audioHasSigned = 0; if (defined($scheduleDetails->{'audioProperties'})) { # Ugly because dtd only allows one type, and source data # may have many (in any order) my $audioHasDolbySurround = 0; my $audioHasDolby = 0; my $audioHasStereo = 0; foreach my $audioProperty(@{$scheduleDetails->{'audioProperties'}}) { $audioHasDolbySurround = 1 if ($audioProperty eq 'DD 5.1'); $audioHasDolby = 1 if ($audioProperty eq 'Dolby'); $audioHasStereo = 1 if ($audioProperty eq 'stereo'); $audioHasCC = 1 if ($audioProperty eq 'cc'); $audioHasSubtitle = 1 if ($audioProperty eq 'subtitled'); $audioHasDVS = 1 if ($audioProperty eq 'dvs'); $audioHasSigned = 1 if ($audioProperty eq 'signed'); } if ($audioHasDolbySurround || $audioHasDolby || $audioHasStereo) { $w->startTag('audio'); if ($audioHasDolbySurround) { $w->dataElement('stereo', 'dolby digital'); } elsif ($audioHasDolby) { $w->dataElement('stereo', 'dolby'); } elsif ($audioHasStereo) { $w->dataElement('stereo', 'stereo'); } $w->endTag('audio'); } } # If the schedule has marked this as a new showing, do not add in # any previously-shown indication. Don't use supplemental data for # originalAirDate since generic data is not relevant for this showing. # Date transformation occurs because XMLTV uses their standardized # dates, while Schedules Direct uses YYYY-MM-DD if (!$newShowing) { if (defined($programDetails->{'originalAirDate'})) { my $originalAirDate = $programDetails->{'originalAirDate'}; my $offset = ' +0000'; $offset = '' if (exists($GRABBER_FIXUPS->{'NO_PREVIOUSLY_SHOWN_ZONE_OFFSET'})); my $start = substr($originalAirDate, 0, 4) . substr($originalAirDate, 5, 2) . substr($originalAirDate, 8, 2) . $offset; $w->emptyTag('previously-shown', start => $start); } else { $w->emptyTag('previously-shown'); } } # XMLTV premiere/last-chance is sort of arbitrarily # defined, so we decide on our own mapping (while # season finale may not be a last-chance, since # in the US every season finale may be a series # finale (no renewal before its time) we just treat # it as the last-chance). if (defined($scheduleDetails->{'premiere'})) { my $premiere = $scheduleDetails->{'premiere'}; $w->emptyTag('premiere') if ($premiere); } elsif (defined($scheduleDetails->{'isPremiereOrFinale'})) { my $premiereType = $scheduleDetails->{'isPremiereOrFinale'}; if (($premiereType eq 'Series Premiere') || ($premiereType eq 'Season Premiere')) { $w->dataElement('premiere', $premiereType); } if (($premiereType eq 'Series Finale') || ($premiereType eq 'Season Finale')) { $w->dataElement('last-chance', $premiereType); } } # Carried forward from audio eval to match DTD $w->emptyTag('subtitles', 'type' => 'teletext') if ($audioHasCC); $w->emptyTag('subtitles', 'type' => 'onscreen') if ($audioHasSubtitle); $w->emptyTag('subtitles', 'type' => 'deaf-signed') if ($audioHasSigned); # XMLTV ratings (and the system) are arbitrary values, and # have no implied priority or order. However, for # Schedules Direct data there maybe different ratings for # a body (one in the show/series, and one in the program, # so we store only the more specific if multiple exist. # We remap the rating agency to the MythTV standard, as # it is as good of a standard as anything else, and makes # importing the data much easier. A value add for # Schedules Direct is that they also provide contentAdvisory # markings at the top level. Gracenote (the upstream) is # adding advisories to the individual ratings body in the # contentRating, which is usually correct, as any advisory # mostly only apply to the agency like VCHIP ratings such # as TV-14, with an advisory of Dialog (VCHIP is one of # the few ratings with such advisory modifiers). That # said, various advisories have been seen in other ratings # systems occasionally, and some movies appear to have # advisories marked even without a VCHIP rating applied. # Also note that an advisory is rating specific. A dialog # that causes an advisory for a TV-PG rating might very # well not result in an advisory for a TV-14 rating where # the more mature audiences can handle the specific dialog. # This is a work in progress, and currently there are # anomalies in the data. As part of the transition from # where we were to where we will eventually be, we will at # this time just collect all possible advisories and add # them to the eventual advisory ratings. This will likely # change as Gracenote (and Schedules Direct) modify their # approach and get their data more consistent. my $ratings = {}; my $advisories = {}; # Supplemental can have generic show ratings if (defined($supplementalDetails->{'contentRating'})) { foreach my $rating(@{$supplementalDetails->{'contentRating'}}) { my $body = $rating->{'body'}; my $code = $rating->{'code'}; ($body, $code) = mapRatingAgency($body, $code); if (defined($body) && defined($code) && ($code ne '')) { $ratings->{$body} = $code; } if ((defined($rating->{'contentAdvisory'})) && (ref($rating->{'contentAdvisory'}) eq 'ARRAY')) { foreach my $advisory(@{$rating->{'contentAdvisory'}}) { $advisories->{$advisory} = 1; } } } } if (defined($supplementalDetails->{'contentAdvisory'})) { foreach my $advisory(@{$supplementalDetails->{'contentAdvisory'}}) { $advisories->{$advisory} = 1; } } # Programs can have rating for this specific program if (defined($programDetails->{'contentRating'})) { foreach my $rating(@{$programDetails->{'contentRating'}}) { my $body = $rating->{'body'}; my $code = $rating->{'code'}; ($body, $code) = mapRatingAgency($body, $code); if (defined($body) && defined($code) && ($code ne '')) { $ratings->{$body} = $code; } if ((defined($rating->{'contentAdvisory'})) && (ref($rating->{'contentAdvisory'}) eq 'ARRAY')) { foreach my $advisory(@{$rating->{'contentAdvisory'}}) { $advisories->{$advisory} = 1; } } } } if (defined($programDetails->{'contentAdvisory'})) { foreach my $advisory(@{$programDetails->{'contentAdvisory'}}) { $advisories->{$advisory} = 1; } } # Write out the the collected ratings and advisories foreach my $rating(sort keys %{$ratings}) { $w->startTag('rating', 'system' => $rating); $w->dataElement('value', $ratings->{$rating}); $w->endTag('rating'); } foreach my $advisory(sort keys %{$advisories}) { $w->startTag('rating', 'system' => 'advisory'); $w->dataElement('value', $advisory); $w->endTag('rating') } # XMLTV star-rating starts from zero (so if rating agency is 1-4, # we adjust the reported values to be from 0-3. my $starRatings = {}; if (defined($supplementalDetails->{'movie'}->{'qualityRating'})) { foreach my $quality(@{$supplementalDetails->{'movie'}->{'qualityRating'}}) { my $body = $quality->{'ratingsBody'}; my $min = $quality->{'minRating'}; my $max = $quality->{'maxRating'}; my $incr = $quality->{'increment'}; my $rating = $quality->{'rating'}; if (defined($body) && defined($min) && defined($max) && defined($incr) && defined($rating) && looks_like_number($min) && looks_like_number($max) && looks_like_number($incr) && looks_like_number($rating)) { $min = 0 + $min; $max = 0 + $max; $incr = 0 + $incr; $rating = 0 + $rating; $rating = $min if ($rating < $min); $rating = $max if ($rating > $max); my $adjustedRating = ($rating - $min); my $adjustedMax = ($max - $min); $starRatings->{$body} = "$adjustedRating/$adjustedMax"; } } } if (defined($programDetails->{'movie'}->{'qualityRating'})) { foreach my $quality(@{$programDetails->{'movie'}->{'qualityRating'}}) { my $body = $quality->{'ratingsBody'}; my $min = $quality->{'minRating'}; my $max = $quality->{'maxRating'}; my $incr = $quality->{'increment'}; my $rating = $quality->{'rating'}; if (defined($body) && defined($min) && defined($max) && defined($incr) && defined($rating) && looks_like_number($min) && looks_like_number($max) && looks_like_number($incr) && looks_like_number($rating)) { $min = 0 + $min; $max = 0 + $max; $incr = 0 + $incr; $rating = 0 + $rating; $rating = $min if ($rating < $min); $rating = $max if ($rating > $max); my $adjustedRating = ($rating - $min); my $adjustedMax = ($max - $min); $starRatings->{$body} = "$adjustedRating/$adjustedMax"; } } } foreach my $body(sort keys %{$starRatings}) { $w->startTag('star-rating', 'system' => $body); $w->dataElement('value', $starRatings->{$body}); $w->endTag('star-rating'); } $w->endTag('programme'); $programsWritten++; } $DBH->commit(); undef $sth; print (STDERR " $programsWritten program schedules processed\n") if (!$quiet); $w->endTag('tv'); $w->end(); # # Our work here is done # finalize: print (STDERR "Pruning the local database\n") if (!$quiet); DB_prune(); exit(0); # # configureGrabber # # Perform the configure function for XMLTV # # NOTE: While this grabber is (technically) apiconfig # compliant, one must run (outside of --configure) # this script with the --manage-lineups option to # create the local database with the username and # password hash, and to add/delete lineups from the # Schedules Direct account. # # NOTE: We do not utilze the "select-channels" functionality # in XMLTV, because it addresses the (actual) selection # of "stations", and not "channels". A "station" is a # programming entity which has a schedule of programs. # A "channel" is a technical means of delivering a # particular "station". Typically, in the real world, # many "channels" deliver the same "station". # # Input: # stage - the "stage" for configure # conf - the (current) conf hash # Output: # result - the xml configure string # sub configureGrabber { my ($stage, $conf, undef) = @_; my $result; my $writer = XMLTV::Configure::Writer->new( OUTPUT => \$result, grabber => $SCRIPT_NAME, encoding => 'iso-8859-1' ); $writer->start ( { grabber => $SCRIPT_NAME } ); if ($stage eq 'start') { $writer->write_string ( { id => 'database', title => [ [ 'Database for Schedules Direct EPG', 'en' ] ], description => [ [ "$SCRIPT_NAME uses a local database for downloaded EPG data. Please specify the database name created via $SCRIPT_NAME --manage-lineups", 'en' ] ], default => File::HomeDir->my_home . "/.xmltv/SchedulesDirect.DB", } ); $writer->end('select-lineup'); } elsif ($stage eq 'select-lineup') { DB_open($conf->{'database'}->[0]); SD_login(); # Login SD_downloadLineups(); # Update our SD lineups in the DB my $sql = "select lineup, name, transport, location, details from lineups order by lineup"; my $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_VARCHAR ); $sth->bind_col( 3, undef, SQL_VARCHAR ); $sth->bind_col( 4, undef, SQL_VARCHAR ); $sth->bind_col( 5, undef, SQL_VARCHAR ); my $lu = $sth->fetchall_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; if (scalar(@{$lu}) == 0) { print (STDERR "No lineups are defined in your Schedules Direct account\n"); print (STDERR "To manage your lineups, please re-run $SCRIPT_NAME --manage-lineups\n"); print (STDERR "and re-run $SCRIPT_NAME --configure to complete the configuration\n"); exit(1); } $writer->start_selectmany ( { id => 'lineup', title => [ [ 'Schedules Direct Lineup', 'en' ] ], description => [ [ 'Select the lineup(s) associated with this configuration', 'en' ] ], } ); for my $l (@{$lu}) { my $id = $l->[0]; my $lineupDesc = lineupDesc($l->[1], $l->[2], $l->[3]); $writer->write_option ( { value => $id, text => [ [ "$id - $lineupDesc", 'en' ] ] } ); } $writer->end_selectmany(); $writer->end('3rdparty-metadata'); } elsif ($stage eq '3rdparty-metadata') { $writer->start_selectone ( { id => '3rdparty-metadata', title => [ [ '3rd party metadata references', 'en' ], ], description => [ [ 'Specify whether to include 3rd party metadata references in the generated XMLTV', 'en' ] ], } ); $writer->write_option ( { value => 'enabled', text => [ [ 'Yes - Enable 3rd party metadata references', 'en'] ] } ); $writer->write_option ( { value => 'disabled', text => [ [ 'No - Disable 3rd party metadata references', 'en'] ] } ); $writer->end_selectone(); $writer->end('extended-video-quality'); } elsif ($stage eq 'extended-video-quality') { $writer->start_selectone ( { id => 'extended-video-quality', title => [ [ 'Extended XMLTV video quality values (HDR, UHDTV)', 'en' ], ], description => [ [ 'Specify whether to specify the extended video quality values (HDR, UHDTV) in the generated XMLTV', 'en' ] ], } ); $writer->write_option ( { value => 'disabled', text => [ [ 'No - Disable extended quality values', 'en'] ] } ); $writer->write_option ( { value => 'enabled', text => [ [ 'Yes - Enable extended quality values', 'en'] ] } ); $writer->end_selectone(); $writer->end('mythtv'); } elsif ($stage eq 'mythtv') { $writer->start_selectone ( { id => 'mythtv-categories', title => [ [ 'MythTV category processing', 'en' ], ], description => [ [ 'Specify whether the XMLTV categories should be MythTV ordered', 'en' ] ], } ); $writer->write_option ( { value => 'enabled', text => [ [ 'Yes - Enable MythTV Category order', 'en'] ] } ); $writer->write_option ( { value => 'disabled', text => [ [ 'No - Do not enable MythTV Category order', 'en'] ] } ); $writer->end_selectone(); $writer->end('station-logo-order'); } elsif ($stage eq 'station-logo-order') { $writer->start_selectone ( { id => 'station-logo-order', title => [ [ 'Station logo ordering', 'en' ], ], description => [ [ 'Specify the order of station logos', 'en' ] ], } ); $writer->write_option ( { value => '', text => [ [ 'None specified (order as received)', 'en' ] ] } ); $writer->write_option ( { value => 'Gracenote/dark', text => [ [ 'Gracenote/dark ordered first (Gracenote logo for dark backgrounds)', 'en' ] ] } ); $writer->write_option ( { value => 'Gracenote/light', text => [ [ 'Gracenote/light ordered first (Gracenote logo for light backgrounds)', 'en' ] ] } ); $writer->write_option ( { value => 'Gracenote/gray', text => [ [ 'Gracenote/gray ordered first (Gracenote logo with grayscale for light backgrounds)', 'en' ] ] } ); $writer->write_option ( { value => 'Gracenote/white', text => [ [ 'Gracenote/white ordered first (Gracenote logo with all white for dark backgrounds)', 'en' ] ] } ); $writer->end_selectone(); $writer->end('select-channels'); } else { die "Unknown stage $stage"; } return $result; } # # listChannels # # Perform the list-channels function per the XMLTV standard # # Input: # conf - the conf hash # opt - the opt hash # Output: # result - the xml configure string # sub listChannels { ($conf, $opt, undef) = @_; configValidate($conf, $opt); $debug = $opt->{'debug'}; $quiet = $opt->{'quiet'}; $SD->Debug(1) if ($debug); $download = 0 if ($opt->{'no-download'}); print (STDERR "Opening the local database\n") if (!$quiet); DB_open($conf->{'database'}->[0]); if ($opt->{'force-download'}) { print (STDERR " clearing existing database to force full download\n") if (!$quiet); DB_clean(); } # # If we are downloading, allow for optimization # if ($download) { print (STDERR "Obtaining authentication token for Schedules Direct\n") if (!$quiet); SD_login(); my $expiry = $SD->accountExpiry; if (!defined($expiry)) { print (STDERR "Unable to obtain the account expiration date: " . $SD->ErrorString . "\n"); exit(1); } my $expiryDateTime = DateTime::Format::ISO8601->parse_datetime($expiry); print (STDERR " Schedules Direct account expires on " . $expiryDateTime . "\n") if (!$quiet); # # Start the download process # print (STDERR "Downloading data from Schedules Direct\n") if (!$quiet); # # Always make sure we have a current lineup list # print (STDERR " downloading account lineups from Schedules Direct\n") if (!$quiet); SD_downloadLineups(); # # Validate that the configured lineup exists in our database # lineupValidate($conf->{'lineup'}); # # Get our current Schedules Direct maps (channels and # stations) for our lineup and feed to our DB if needed # for my $lineup(@{$conf->{'lineup'}}) { if (SD_isLineupFetchRequired([$lineup])) { print (STDERR " downloading channel and station maps for lineup $lineup \n") if (!$quiet); SD_downloadLineupMaps($lineup); } else { print (STDERR " not downloading channel and station maps for lineup $lineup (data current)\n") if (!$quiet); } } } else { lineupValidate($conf->{'lineup'}); my $token = DB_settingsGet('token'); $SD->Token($token) if (defined($token)); } print (STDERR "Processing data and creating XMLTV output\n") if (!$quiet); my $w = XML::Writer->new( 'ENCODING' => 'UTF-8', 'DATA_MODE' => 1, 'DATA_INDENT' => 1, 'OUTPUT' => 'self' ); $w->xmlDecl('UTF-8'); $w->comment($SD_COMMENT); $w->doctype( 'tv', undef, 'xmltv.dtd' ); $w->startTag('tv', 'generator-info-name' => $SCRIPT_NAME, 'generator-info-url' => $SCRIPT_URL, 'source-info-name' => $SD_DESC, 'source-info-url' => $SD_SITEURL ); my $channelsWritten = channelWriter($conf->{'lineup'}, $w); $w->endTag('tv'); $w->end(); print (STDERR " $channelsWritten channels processed\n") if (!$quiet); return(encode('UTF-8', $w->to_string)); } # # channelWriter # # Convenience routine to write the XMLTV channels. # Output is written to the xmltv writer # # Input: # lineup(s) - the lineup(s) to use # writer - the xmltv writer # Output: # written - number of channels written # sub channelWriter { my ($lineups, $writer, undef) = @_; my $sql; my $sth; my $param; my $channelsWritten = 0; # # Select our lineup channels/stations # $sql = 'select distinct channels.station, channels.channum, channels.details, stations.details from channels as channels left join stations as stations on stations.station = channels.station where channels.lineup in ( ' . join(', ', ('?') x scalar(@{$lineups})) . ' ) and channels.selected = 1 order by channels.station'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $param = 1; for (my $i=0; $i < scalar(@{$lineups}); $i++) { $sth->bind_param( $param, @{$lineups}[$i], SQL_VARCHAR); $param++; } $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_VARCHAR ); $sth->bind_col( 3, undef, SQL_VARCHAR ); $sth->bind_col( 4, undef, SQL_VARCHAR ); my $channels = $sth->fetchall_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; # Process each channel in our lineup foreach my $r(@{$channels}) { my $sID = $r->[0]; my $channum = $r->[1]; my $c = eval { $JSON->decode($r->[2]) } || {}; my $s = eval { $JSON->decode($r->[3]) } || {};; $writer->startTag('channel', 'id' => generateRFC2838($sID) ) ; my $name = ''; $name = $s->{'name'} if (defined($s->{'name'})); my $callsign = ''; $callsign = $s->{'callsign'} if (defined($s->{'callsign'})); $name = $callsign if ($name eq ''); $name = $channum if ($name eq ''); $callsign = $channum if ($callsign eq ''); $writer->dataElement('display-name', $name) if ($name ne ''); $writer->dataElement('display-name', $callsign) if ($callsign ne ''); $writer->dataElement('display-name', $channum) if ($channum ne ''); # We return all stationLogo's unless asked to not return any, # or to return only the first. if ((defined($s->{'stationLogo'})) && (ref($s->{'stationLogo'}) eq 'ARRAY') && (!exists($GRABBER_FIXUPS->{'NO_STATION_LOGOS'}))) { for my $sl (sort { logoPriority($b) <=> logoPriority($a) } @{$s->{'stationLogo'}}) { next if (ref($sl) ne 'HASH'); if(defined($sl->{'URL'})) { if (defined($sl->{'width'}) && defined($sl->{'height'})) { $writer->emptyTag('icon', 'src' => $sl->{'URL'}, 'width' => $sl->{'width'}, 'height' => $sl->{'height'}); } else { $writer->emptyTag('icon', 'src' => $sl->{'URL'}); } last if (exists($GRABBER_FIXUPS->{'NO_MULTIPLE_STATION_LOGOS'})); } } } $writer->endTag('channel'); $channelsWritten++; } return ($channelsWritten); } # # listLineups # # Perform the list-lineups function per XMLTV # # Input: # opt - the opt hash # Output: # result - the xml configure string # sub listLineups { ($opt, undef) = @_; $conf = LoadConfig($opt->{'config-file'}); my $sql; my $sth; my $param; configValidate($conf, $opt); $debug = $opt->{'debug'}; $quiet = $opt->{'quiet'}; $SD->Debug(1) if ($debug); $download = 0 if ($opt->{'no-download'}); print (STDERR "Opening the local database\n") if (!$quiet); DB_open($conf->{'database'}->[0]); if ($opt->{'force-download'}) { print (STDERR " clearing existing database to force full download\n") if (!$quiet); DB_clean(); } if ($download) { print (STDERR "Obtaining authentication token for Schedules Direct\n") if (!$quiet); SD_login(); my $expiry = $SD->accountExpiry; if (!defined($expiry)) { print (STDERR "Unable to obtain the account expiration date: " . $SD->ErrorString . "\n"); exit(1); } my $expiryDateTime = DateTime::Format::ISO8601->parse_datetime($expiry); print (STDERR " Schedules Direct account expires on " . $expiryDateTime . "\n") if (!$quiet); # # Start the download process # print (STDERR "Downloading data from Schedules Direct\n") if (!$quiet); # # Always make sure we have a current lineup list # print (STDERR " downloading account lineups from Schedules Direct\n") if (!$quiet); SD_downloadLineups(); } else { my $token = DB_settingsGet('token'); $SD->Token($token) if (defined($token)); } $sql = 'select lineup, name, transport, location, details from lineups order by lineup'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_VARCHAR ); $sth->bind_col( 3, undef, SQL_VARCHAR ); $sth->bind_col( 4, undef, SQL_VARCHAR ); $sth->bind_col( 5, undef, SQL_VARCHAR ); my $lu = $sth->fetchall_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; print (STDERR "Processing data and creating XMLTV output\n") if (!$quiet); my $lineupsWritten = 0; my $w = XML::Writer->new( 'ENCODING' => 'UTF-8', 'DATA_MODE' => 1, 'DATA_INDENT' => 1, OUTPUT => 'self' ); $w->xmlDecl('UTF-8'); $w->comment('Note: list-lineups and get-lineup is still unofficial in XMLTV, and the format and content of this xml is liable to change.'); $w->comment($SD_COMMENT); $w->startTag('xmltv-lineups', 'modified' => strftime("%FT%T %z", localtime), 'generator-info-name' => $SCRIPT_NAME, 'generator-info-url' => $SCRIPT_URL, 'source-info-name' => $SD_DESC, 'source-info-url' => $SD_SITEURL ); for my $l (@{$lu}) { my $id = $l->[0]; my $lineupDesc = lineupDesc($l->[1], $l->[2], $l->[3]); $w->startTag('xmltv-lineup', 'id' => $id ); my $type = mapTransport($l->[2]); $w->dataElement('type', $type); $w->dataElement('display-name', $lineupDesc); $w->endTag('xmltv-lineup'); $lineupsWritten++; } $w->endTag('xmltv-lineups'); $w->end(); print (STDERR " $lineupsWritten lineups processed\n") if (!$quiet); return(encode('UTF-8', $w->to_string)); } # # getLineup # # Perform the get-lineup function per XMLTV # # Input: # conf - the conf has # opt - the opt hash # Output: # result - the xml configure string # sub getLineup { ($conf, $opt, undef) = @_; my $sql; my $sth; my $param; configValidate($conf, $opt); $debug = $opt->{'debug'}; $quiet = $opt->{'quiet'}; $SD->Debug(1) if ($debug); $download = 0 if ($opt->{'no-download'}); print (STDERR "Opening the local database\n") if (!$quiet); DB_open($conf->{'database'}->[0]); if ($opt->{'force-download'}) { print (STDERR " clearing existing database to force full download\n") if (!$quiet); DB_clean(); } # # If we are downloading, allow for optimization # if ($download) { print (STDERR "Obtaining authentication token for Schedules Direct\n") if (!$quiet); SD_login(); my $expiry = $SD->accountExpiry; if (!defined($expiry)) { print (STDERR "Unable to obtain the account expiration date: " . $SD->ErrorString . "\n"); exit(1); } my $expiryDateTime = DateTime::Format::ISO8601->parse_datetime($expiry); print (STDERR " Schedules Direct account expires on " . $expiryDateTime . "\n") if (!$quiet); # # Start the download process # print (STDERR "Downloading data from Schedules Direct\n") if (!$quiet); # # Always make sure we have a current lineup list # print (STDERR " downloading account lineups from Schedules Direct\n") if (!$quiet); SD_downloadLineups(); # # Validate that the configured lineup exists in our database # lineupValidate($conf->{'lineup'}); # # Get our current Schedules Direct maps (channels and # stations) for our lineup and feed to our DB if needed # for my $lineup(@{$conf->{'lineup'}}) { if (SD_isLineupFetchRequired([$lineup])) { print (STDERR " downloading channel and station maps for lineup $lineup \n") if (!$quiet); SD_downloadLineupMaps($lineup); } else { print (STDERR " not downloading channel and station maps for lineup $lineup (data current)\n") if (!$quiet); } } } else { lineupValidate($conf->{'lineup'}); my $token = DB_settingsGet('token'); $SD->Token($token) if (defined($token)); } # # Collect our lineup(s) information. # $sql = 'select lineup, name, transport, location, details from lineups where lineup in ( ' . join(', ', ('?') x scalar(@{$conf->{'lineup'}})) . ' ) order by lineup'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $param = 1; for (my $i=0; $i < scalar(@{$conf->{'lineup'}}); $i++) { $sth->bind_param( $param, @{$conf->{'lineup'}}[$i], SQL_VARCHAR); $param++; } $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_VARCHAR ); $sth->bind_col( 3, undef, SQL_VARCHAR ); $sth->bind_col( 4, undef, SQL_VARCHAR ); $sth->bind_col( 5, undef, SQL_VARCHAR ); my $lu = $sth->fetchall_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; print (STDERR "Processing data and creating XMLTV output\n") if (!$quiet); my $channelsWritten = 0; my $w = XML::Writer->new( 'ENCODING' => 'UTF-8', 'DATA_MODE' => 1, 'DATA_INDENT' => 1, OUTPUT => 'self' ); $w->xmlDecl('UTF-8'); $w->comment('Note: list-lineups and get-lineup is still unofficial in XMLTV, and the format and content of this xml is liable to change.'); $w->comment($SD_COMMENT); $w->startTag('xmltv-lineups', 'modified' => strftime("%FT%T %z", localtime), 'generator-info-name' => $SCRIPT_NAME, 'generator-info-url' => $SCRIPT_URL, 'source-info-name' => $SD_DESC, 'source-info-url' => $SD_SITEURL ); for my $l (@{$lu}) { my $id = $l->[0]; my $lineupDesc = lineupDesc($l->[1], $l->[2], $l->[3]); $w->startTag('xmltv-lineup', 'id' => $id ); my $type = mapTransport($l->[2]); $w->dataElement('type', $type); $w->dataElement('display-name', $lineupDesc); # # Process each channel/station in the lineup # $sql = 'select distinct channels.station, channels.channum, channels.details, stations.details, lineups.transport from channels as channels left join stations as stations on stations.station = channels.station left join lineups as lineups on lineups.lineup = channels.lineup where channels.lineup = ? and channels.selected = 1 order by channels.station'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $id, SQL_VARCHAR ); $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_VARCHAR ); $sth->bind_col( 3, undef, SQL_VARCHAR ); $sth->bind_col( 4, undef, SQL_VARCHAR ); $sth->bind_col( 5, undef, SQL_VARCHAR ); my $channels = $sth->fetchall_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; foreach my $r(@{$channels}) { my $sID = $r->[0]; my $channum = $r->[1]; my $c = eval { $JSON->decode($r->[2]) } || {}; my $s = eval { $JSON->decode($r->[3]) } || {}; my $SDtype = $r->[4] || 'Unknown'; my $type = mapTransport($r->[4]); $w->startTag('lineup-entry'); if (defined($channum) && ($channum ne '')) { $w->dataElement('preset', $channum); } $w->startTag('station', 'rfc2838' => generateRFC2838($sID) ); my $name = $s->{'name'}; my $shortname = $s->{'callsign'}; $name = $shortname if (!defined($name) || ($name eq '')); $w->dataElement('name', $name) if (defined($name) && ($name ne '')); $w->dataElement('short-name', $shortname) if (defined($shortname) && ($shortname ne '')); # We return all stationLogo's unless asked to not return any, # or to return only the first. if ((defined($s->{'stationLogo'})) && (ref($s->{'stationLogo'}) eq 'ARRAY') && (!exists($GRABBER_FIXUPS->{'NO_STATION_LOGOS'}))) { for my $sl (sort { logoPriority($b) <=> logoPriority($a) } @{$s->{'stationLogo'}}) { next if (ref($sl) ne 'HASH'); if(defined($sl->{'URL'})) { if (defined($sl->{'width'}) && defined($sl->{'height'})) { $w->emptyTag('logo', 'url' => $sl->{'URL'}, 'width' => $sl->{'width'}, 'height' => $sl->{'height'}); } else { $w->emptyTag('logo', 'url' => $sl->{'URL'}); } last if (exists($GRABBER_FIXUPS->{'NO_MULTIPLE_STATION_LOGOS'})); } } } $w->endTag('station'); if (($SDtype eq 'Cable') || ($SDtype eq 'Satellite') || ($SDtype eq 'IPTV')) { $w->startTag('stb-channel'); if (defined($c->{'channel'}) && looks_like_number($c->{'channel'})) { my $preset = $c->{'channel'}; $preset = 0 + $preset; $w->dataElement('stb-preset', $preset); } $w->endTag('stb-channel'); } elsif ($SDtype eq 'Antenna') { my $atscMajor = $c->{'atscMajor'}; my $atscMinor = $c->{'atscMinor'}; my $atscType = $c->{'atscType'}; my $ATSC = (defined($atscMajor) && defined($atscMinor) && looks_like_number($atscMajor) && looks_like_number($atscMinor)); my $ATSC3 = ($ATSC && defined($atscType) && ($atscType eq '3.0')); if ($ATSC) { $atscMajor = 0 + $atscMajor; $atscMinor = 0 + $atscMinor; $w->startTag('atsc-channel'); if ($ATSC3) { $w->dataElement('system', 'US-ATSC-3.0'); } else { $w->dataElement('system', 'US-ATSC'); } } else { $w->startTag('analog-channel'); $w->dataElement('system', 'NTSC-M'); } if (defined($channum) && ($channum ne '')) { $w->dataElement('number', $channum); } my $fccChan = $c->{'uhfVhf'}; if (defined($fccChan)) { $w->dataElement('frequency', mapUSATSCChannelToFrequency($fccChan)); } if ($ATSC) { # This will be wrong some of the time, but until # we get better data, it is what it is (and it # turns out it is correct a lot of the time) $w->dataElement('program', $atscMinor); } if (defined($s->{'callsign'})) { $w->dataElement('fcc-callsign', $s->{'callsign'}); } # Needed for xsd compliance, even though it was supposed to be optional for US analog $w->emptyTag('cni','tt-8-30-1' => '') if (!$ATSC); if ($ATSC) { $w->endTag('atsc-channel'); } else { $w->endTag('analog-channel'); } } elsif (($SDtype eq 'DVB-T') || ($SDtype eq 'DVB-S') | ($SDtype eq 'DVB-C')) { $w->startTag('dvb-channel'); my $freq = $c->{'frequencyHz'}; if (defined($freq) && looks_like_number($freq)) { $freq = 0 + $freq; $w->dataElement('frequency', $freq); } my $networkID = $c->{'networkID'}; if (defined($networkID) && looks_like_number($networkID)) { $networkID = 0 + $networkID; $w->dataElement('original-network-id', $networkID); } my $transportID = $c->{'transportID'}; if (defined($transportID) && looks_like_number($transportID)) { $transportID = 0 + $transportID; $w->dataElement('transport-id', $transportID); } my $serviceID = $c->{'serviceID'}; if (defined($serviceID) && looks_like_number($serviceID)) { $serviceID = 0 + $serviceID; $w->dataElement('service-id', $serviceID); } my $lcn = $c->{'logicalChannelNumber'}; if (defined($lcn) && looks_like_number($lcn)) { $lcn = 0 + $lcn; $w->dataElement('lcn', $lcn); } my $provider = $c->{'providerCallsign'}; if (defined($provider)) { $w->dataElement('provider-name', $provider); } $w->endTag('dvb-channel'); } $channelsWritten++; $w->endTag('lineup-entry'); } $DBH->commit(); undef $sth; $w->endTag('xmltv-lineup'); } $w->endTag('xmltv-lineups'); $w->end(); print (STDERR " $channelsWritten channels processed\n") if (!$quiet); return(encode('UTF-8', $w->to_string)); } # # loadOldConfig # # Perform the (internal) load old config function per XMLTV # # Note: This sub exists only to allow the grabber to # manage lineups without a configuration file # # Input: # opt - the opt hash # Output: # result - the xml configure string # sub loadOldConfig { return {}; } # # SD_login # # Convenience function for login and checks # for success. All errors are fatal. # # Input: # # Output: # # sub SD_login { my $username = DB_settingsGet('username'); my $passwordhash = DB_settingsGet('passwordhash'); my $pswdhash = $passwordHash || $passwordhash; my $token; $token = DB_settingsGet('token') if (!defined($passwordHash)); if (!defined($username)) { print (STDERR "Your database is not configured to access the Schedules Direct\n"); print (STDERR "service (the username is not available in the settings table).\n"); print (STDERR "Please re-run $SCRIPT_NAME --manage-lineups to\n"); print (STDERR "initialize the database\n"); exit(1); } if (!defined($pswdhash)) { print (STDERR "Your database is not configured to access the Schedules Direct\n"); print (STDERR "service automatically without manually entering the passwordhash.\n"); print (STDERR "Either invoke the grabber specifying the --passwordhash option,\n"); print (STDERR "or re-run $SCRIPT_NAME --manage-lineups to initialize\n"); print (STDERR "and update the database to store the hash in the database.\n"); exit(1); } if (!defined($token = $SD->obtainToken($username, undef, $pswdhash, $token))) { print (STDERR "Unable to authenticate to Schedules Direct: " . $SD->ErrorString() . "\n"); exit(1); } if ((defined($token)) && (defined($passwordhash)) && (!defined($passwordHash))) { DB_settingsSet('token', $token); $DBH->commit(); } if (!defined($SD->obtainStatus())) { print (STDERR "Unable to obtain Schedules Direct server status: " . $SD->ErrorString() . "\n"); exit(1); } my $online = $SD->isOnline; if (!defined($online)) { print (STDERR "Unable to obtain Schedules Direct server online status: " . $SD->ErrorString() . "\n"); exit(1); } if (!$online) { print (STDERR "The Schedules Direct service is not currently online, Try again later.\n"); exit(1); } my $expiry = $SD->accountExpiry; if (!defined($expiry)) { print (STDERR "Unable to obtain Schedules Direct account expiration: " . $SD->ErrorString() . "\n"); exit(1); } my $expiryDateTime = DateTime::Format::ISO8601->parse_datetime($expiry); if ($nowDateTime > $expiryDateTime) { print (STDERR "Schedules Direct account expired on " . $expiryDateTime . "\n"); exit(1); } return; } # # SD_isLineupFetchRequired # # We can avoid downloading lineup and map information # if we have updated our maps more recently than the # account lineup information in the account status # indicates (small, but occasionally useful, optimization). # # Input: # lineup(s) - the lineup(s) to check # Output: # result - true (fetch required) or false # sub SD_isLineupFetchRequired { my ($lineups, undef) = @_; my $sql; my $sth; my $accountLineups; my $accountLineupModifiedDateTime; my $fetchRequired = 0; $accountLineups = $SD->obtainLineups(); if (!defined($accountLineups)) { print (STDERR "Unable to obtain Schedules Direct account lineups: " . $SD->ErrorString() . "\n"); exit(1); } # Since each lineup has a (potential) different modified date, we will do it the long way for my $lineup(@{$lineups}) { undef $accountLineupModifiedDateTime; for my $l (@{$accountLineups}) { next if (ref($l) ne 'HASH'); if (defined($l->{'lineupID'}) && ($l->{'lineupID'} eq $lineup)) { $accountLineupModifiedDateTime = DateTime::Format::ISO8601->parse_datetime($l->{'modified'}) if (defined($l->{'modified'})); last; } } $accountLineupModifiedDateTime = $nowDateTime->clone() if (!defined($accountLineupModifiedDateTime)); $sql = 'select 1 from lineups l1 where (l1.lineup = ? and l1.modified <= ?) ' . 'union select 1 where not exists (select 1 from lineups l2 where l2.lineup = ?)'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->bind_param( 2, DateTime::Format::SQLite->format_datetime($accountLineupModifiedDateTime), SQL_DATETIME ); $sth->bind_param( 3, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $fetchRequired |= ($sth->fetchrow_array() || 0); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->finish(); $DBH->commit(); undef $sth; } return ($fetchRequired); } # # SD_downloadLineups # # Convenience routine to download lineups and # place into our database. Errors are fatal. # # Input: # # Output: # # sub SD_downloadLineups { my $sql; my $sth; my $sql1; my $sth1; my $sql2; my $sth2; my $lu; my $lineups; my $param; my @accountLineups = (); # # Obtain our lineups # $lineups = $SD->obtainLineups(); if (!defined($lineups)) { print (STDERR "Unable to obtain Schedules Direct account lineups: " . $SD->ErrorString() . "\n"); exit(1); } # # insert or ignore, and then update in order to initialize # downloaded and modified as 1970-01-01 00:00:00 if new, # and maintain the dates if existing. # $sql = "insert or ignore into lineups (lineup, name, location, transport, details) values (?, ?, ?, ?, ?)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sql1 = "update lineups set name = ?, location = ?, transport = ?, details = ? where lineup = ?"; $sth1 = $DBH->prepare_cached($sql1); if (!defined($sth1)) { print (STDERR "Unexpected error when preparing statement ($sql1): " . $DBH->errstr . "\n"); exit(1); } for my $l (@{$lineups}) { next if ((ref($l) ne 'HASH') || (!defined($l->{'lineupID'}))); my $id = $l->{'lineupID'}; push(@accountLineups, $id); my $name = $l->{'name'} || ''; my $transport = $l->{'transport'} || ''; my $location = $l->{'location'} || ''; my $details = $JSON->canonical->encode($l); $sth->bind_param( 1, $id, SQL_VARCHAR ); $sth->bind_param( 2, $name, SQL_VARCHAR ); $sth->bind_param( 3, $location, SQL_VARCHAR ); $sth->bind_param( 4, $transport, SQL_VARCHAR ); $sth->bind_param( 5, $details, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth1->bind_param( 1, $name, SQL_VARCHAR ); $sth1->bind_param( 2, $location, SQL_VARCHAR ); $sth1->bind_param( 3, $transport, SQL_VARCHAR ); $sth1->bind_param( 4, $details, SQL_VARCHAR ); $sth1->bind_param( 5, $id, SQL_VARCHAR ); $sth1->execute(); if ($sth1->err) { print (STDERR "Unexpected error when executing statement ($sql1): " . $sth1->errstr . "\n"); $DBH->rollback(); exit(1); } } # # Remove any lineups from our database not in our schedules direct account # $sql2 = 'delete from lineups where lineup not in ( ' . join(', ', ('?') x scalar(@accountLineups)) . ' )'; $sth2 = $DBH->prepare_cached($sql2); if (!defined($sth2)) { print (STDERR "Unexpected error when preparing statement ($sql2): " . $DBH->errstr . "\n"); exit(1); } $param = 1; for (my $i=0; $i < scalar(@accountLineups); $i++) { $sth2->bind_param( $param, $accountLineups[$i], SQL_VARCHAR); $param++; } $sth2->execute(); if ($sth2->err) { print (STDERR "Unexpected error when executing statement ($sql2): " . $sth2->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); return; } # # SD_downloadLineupMaps # # Convenience routine to download maps for a lineup # and place into our database. Errors are fatal. # # Input: # lineup - Lineup to update # Output: # - database updated # sub SD_downloadLineupMaps { my ($lineup, undef) = @_; my $maps = $SD->obtainLineupMaps($lineup); if (!defined($maps)) { print (STDERR "Unable to obtainLineupMap for lineup $lineup: " . $SD->ErrorString() . "\n"); exit(1); } if (!defined($maps->{'map'})) { print (STDERR "Lineup map for lineup $lineup does not contain a channel entity\n"); exit(1); } if (!defined($maps->{'stations'})) { print (STDERR "Lineup map for lineup $lineup does not contain a station entity\n"); exit(1); } my $sql; my $sth; my $lineupChannelsSelected = 1; my $lineupTransport = ''; $sql = "select new_channels_selected, transport from lineups where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, \$lineupChannelsSelected, SQL_INTEGER ); $sth->bind_col( 2, \$lineupTransport, SQL_VARCHAR ); $sth->fetchrow_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->finish(); $DBH->commit(); undef $sth; $sql = "create temp table if not exists channels_backup as select * from channels where 1<>1"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sql = "delete from channels_backup"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sql = "insert into channels_backup select * from channels where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sql = "delete from channels where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sql = "replace into channels (lineup, station, selected, channum, details) values (?, ?, ?, ?, ?)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } foreach my $c (@{$maps->{'map'}}) { my $station = $c->{'stationID'}; $station = '' if (!defined($station)); my $details = $JSON->canonical->encode($c); my $channum = ''; if (($lineupTransport eq 'Cable') || ($lineupTransport eq 'Satellite') || ($lineupTransport eq 'DVB-C') || ($lineupTransport eq 'DVB-T') || ($lineupTransport eq 'DVB-S') || ($lineupTransport eq 'IPTV')) { $channum = $c->{'channel'} if (defined($c->{'channel'})); $channum = 0 + $channum if (looks_like_number($channum)); } elsif ($lineupTransport eq 'Antenna') { my $atscMajor = $c->{'atscMajor'}; my $atscMinor = $c->{'atscMinor'}; my $uhfVhf = $c->{'uhfVhf'}; if (defined($atscMajor) && defined($atscMinor) && looks_like_number($atscMajor) && looks_like_number($atscMinor)) { $atscMajor = 0 + $atscMajor; $atscMinor = 0 + $atscMinor; $channum = "$atscMajor.$atscMinor"; } elsif (defined($uhfVhf) && looks_like_number($uhfVhf)) { $channum = 0 + $uhfVhf; } } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->bind_param( 2, $station, SQL_VARCHAR ); $sth->bind_param( 3, $lineupChannelsSelected, SQL_INTEGER ); $sth->bind_param( 4, $channum, SQL_VARCHAR ); $sth->bind_param( 5, $details, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } } # Preserve previous selected values (if they exist) by copying them across # The match must be by lineup, station, and channum. So if the station # changes, the selection resets (it may be a new station on that channel, # or it could be a change in feed (east coast to west coast), either are # likely for Cable/Satellite, but it is impossible to know the details, # so we have to consider it a new/revised channel. Simliarly, if the # channum changes, we have to consider this a different channel, even # if the station is the same (another channel on the STB, or sometimes # a (new) HD version of a channel, or a repeater channel). In other # words, the preservation works (reasonably well) only when the channel # really stays the same, but it is vulnerable to a certain class of # well known changes in real world lineups. $sql = "update channels set selected = (select selected from channels_backup where channels.lineup = channels_backup.lineup and channels.channum = channels_backup.channum and channels.station = channels_backup.station ) where lineup = ? and exists(select 1 from channels_backup where channels.lineup = channels_backup.lineup and channels.channum = channels_backup.channum and channels.station = channels_backup.station)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sql = "replace into stations (station, details) values (?, ?)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } foreach my $s (@{$maps->{'stations'}}) { my $station = $s->{'stationID'}; next if (!defined($station)); my $details = $JSON->canonical->encode($s); $sth->bind_param( 1, $station, SQL_VARCHAR ); $sth->bind_param( 2, $details, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } } $sql = "update lineups set modified = ? where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $nowDateTimeSQLite, SQL_DATETIME ); $sth->bind_param( 2, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); return; } # # lineupValidate # # Convenience routine to validate that the specified # lineup(s) are still in our Schedules Direct lineup # # If the lineup is not valid we write a message and exit # # Input: # lineup(s) - Lineup(s) to validate # Output: # # sub lineupValidate { my ($lineups, undef) = @_; my $fatal = 0; my $sql; my $sth; foreach my $lineup (@{$lineups}) { $sql = 'select lineup, name, transport, location, details from lineups where lineup = ?'; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err()) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_VARCHAR ); $sth->bind_col( 2, undef, SQL_VARCHAR ); $sth->bind_col( 3, undef, SQL_VARCHAR ); $sth->bind_col( 4, undef, SQL_VARCHAR ); $sth->bind_col( 5, undef, SQL_VARCHAR ); my $llu = $sth->fetchrow_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->finish(); $DBH->commit(); undef $sth; if (!defined($llu)) { print (STDERR "Lineup $lineup is no longer configured in your account at Schedules Direct.\n"); print (STDERR "Please run $SCRIPT_NAME --manage-lineups to manage your Schedules Direct lineups,\n"); print (STDERR "and/or $SCRIPT_NAME --configure to change the configured lineups.\n"); $fatal = 1; } else { my $lineupDeleted = eval { $JSON->decode($llu->[4])->{'isDeleted'} } || 0; if (defined($lineupDeleted) && $lineupDeleted) { print (STDERR "Lineup $lineup has been deleted at Schedules Direct.\n"); print (STDERR "Please run $SCRIPT_NAME --manage-lineups to manage your Schedules Direct lineups,\n"); print (STDERR "and/or $SCRIPT_NAME --configure to change the configured lineups.\n"); $fatal = 1; } } } if ($fatal) { exit(1); } } # # configValidate # # Convenience routine to validate that the configuration # file contains some basic information (database file # and lineup). # # If the configuration does not contain the basic info # we write a message and exit # # Input: # conf - The $conf array # opt - The $opt array # Output: # # sub configValidate { my ($conf, $opt, undef) = @_; if (!defined($conf->{'database'}->[0])) { print (STDERR "Database not defined in config file $opt->{'config-file'}.\n"); print (STDERR "Please run '$SCRIPT_NAME --configure'\n"); exit(1); } if (!defined($conf->{'lineup'}->[0])) { print (STDERR "Lineup not defined in config file $opt->{'config-file'}.\n"); print (STDERR "Please run '$SCRIPT_NAME --configure'\n"); exit(1); } } # # askChoice # # Convenience routine to ask for a selection and # return the value # # Input: # prompt - Prompt # default - (or undef which means the first) # options - array of arrays (inner array is [value, text]) # Output: # value - selected value (or undef for ctrl-D) # sub askChoice { my ($prompt, $default, @options) = @_; my @optionsvalue; my @optionstext; foreach my $option ( @options ) { push @optionsvalue, @{$option}[0]; push @optionstext, @{$option}[1]; } if (!defined($default)) { $default = $optionstext[0]; } my $selection = ask_choice($prompt, $default, @optionstext); return if (!defined($selection)); for ( my $i=0; $i # sub DB_open { my ($dbname, undef) = @_; my $version; my $rc; # # Quick exit if we already have the database open # return if (defined($DBH)); if (!defined($dbname)) { print (STDERR "The Schedules Direct EPG database location is not specified\n"); print (STDERR "Please re-run $SCRIPT_NAME --manage-lineups and/or $SCRIPT_NAME --configure\n"); exit(1); } # # Insure base directory exists # if (! -d dirname("$dbname")) { eval { local $SIG{'__DIE__'}; # ignore user-defined die handlers make_path(dirname("$dbname")); }; if ($@) { print (STDERR "Unable to create parent directory for $dbname: $@"); exit(1); } } $DBH = DBI->connect("DBI:SQLite:dbname=$dbname", "", "", { RaiseError => 0, PrintError => 0, AutoCommit => 0, sqlite_use_immediate_transaction => 0 }); if (!defined($DBH)) { print (STDERR "Unable to open database file $dbname: " . DBI->errstr . "\n"); exit(1); } # # Set extended timeout # $DBH->sqlite_busy_timeout(30000); # # Validate DB version support by first checking # if the database seems to be initialized. # $rc = $DBH->do("select value from settings where tag = 'version'"); if ((!defined($rc)) || ($rc < 0)) { $version = 0; } else { $version = DB_settingsGet('version'); $version = 0 if (!defined($version)); } if ($version =~ /^\d+$/) { $version = 0 + $version; } else { print (STDERR "Database version ($version) is not a valid version number\n"); exit(1); } if ($version > $SCRIPT_DB_VERSION) { print (STDERR "Database version $version is not supported (newer than grabber supported version $SCRIPT_DB_VERSION)\n"); exit(1); } elsif ($version < $SCRIPT_DB_VERSION) { if (0 == $version) ## Initial database creation { $version = 1; print (STDERR "Initializing database $dbname\n") if (!$quiet); # # SQLite specific optimizations that need to # be applied at initial database creation. # $DBH->{'AutoCommit'} = 1; $DBH->do('PRAGMA page_size=4096'); $DBH->do('PRAGMA journal_mode=WAL'); $DBH->do('PRAGMA auto_vacuum=2'); $DBH->do('vacuum'); $DBH->{'AutoCommit'} = 0; $rc = $DBH->do("create table if not exists settings (" . "tag varchar(256) not null primary key, " . "value varchar(256))"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create settings table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create table lineups ( " . "lineup varchar(128) not null primary key, " . "name varchar(128) not null, " . "location varchar(128) not null, " . "transport varchar(64) not null, " . "downloaded datetime not null default '1970-01-01 00:00:00', " . "modified datetime not null default '1970-01-01 00:00:00', " . "new_channels_selected integer not null default 1, " . "details blob not null )"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create lineups table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create table programs ( " . "program varchar(128) not null primary key, " . "hash varchar(64) not null, " . "details blob not null )"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create programs table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create table stations ( " . "station varchar(128) not null primary key, " . "details blob not null )"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create stations table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create table stations_schedules_hash ( " . "station varchar(128) not null, " . "day date not null, " . "hash varchar(64) not null, " . "details blob not null, " . "primary key(station, day) )"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create stations_schedules_hash table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create index stations_schedules_hash_index_hash on stations_schedules_hash (hash)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create stations schedules hash index in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create table channels ( " . "lineup varchar(128) not null, " . "station varchar(128) not null, " . "channum varchar(128) not null default '', " . "selected integer not null default 1, " . "details blob not null )"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create channels table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create index channels_index_lineup_station on channels (lineup, station)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create channel index in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create table schedules_hash ( " . "station varchar(128) not null, " . "day date not null, " . "hash varchar(64) not null, " . "primary key (station, day) )"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create schedules_hash table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create index schedules_hash_index_hash on schedules_hash (hash)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create schedules hash index in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create table schedules ( " . "station varchar(128) not null, " . "day date not null, " . "starttime datetime not null, " . "duration integer not null, " . "program varchar(128) not null, " . "program_hash varchar(64) not null, " . "details blob not null, " . "primary key (station, day, starttime, duration) )"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create schedules table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create index schedules_index_station_starttime on schedules (station, starttime)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create schedules index in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create index schedules_index_program on schedules (program)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create schedules program index in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } DB_settingsSet('version', $version); $DBH->commit(); } if (1 == $version) { $version = 2; print (STDERR "Upgrading database to version $version\n") if (!$quiet); $rc = $DBH->do("alter table programs add column program_supplemental varchar(128)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to add column program_supplemental to programs table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("alter table programs add column downloaded datetime not null default '1970-01-01 00:00:00'"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to add column downloaded to programs table in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create index programs_index_program_supplemental on programs(program_supplemental)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create programs_index_program_supplemental in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $rc = $DBH->do("create index programs_index_downloaded on programs(downloaded)"); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to create programs_index_downloaded in database $dbname: " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } # Update existing programs $sql = "update programs set downloaded = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_param( 1, $nowDateTimeSQLite, SQL_DATETIME ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sql = "update programs set program_supplemental = 'SH' || substr(program,3,8) || '0000' where program like 'EP%'"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } DB_settingsSet('version', $version); $DBH->commit(); } ## if (2 == $version ## Example upgrade (version 2 to 3) ## { ## $version = 3; ## print (STDERR "Updating database to version $version\n") if (!$quiet); ## ## Alter table, create index, ? ## DB_settingsSet('version', $version); ## $DBH->commit(); ## } } $DBH->commit(); return; } # # DB_settingsGet # # Convenience routine to get a setting from the database # # Input: # tag - the tag # Output: # value - of the tag (or undef) # sub DB_settingsGet { my ($tag, undef) = @_; my $value; my $sql; my $sth; $sql = "select value from settings where tag = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $tag, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, \$value, SQL_VARCHAR ); $sth->fetchrow_arrayref(); if ($sth->err) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->finish(); $DBH->commit(); undef $sth; return ($value); } # # DB_settingsSet # # Convenience routine to set a setting in the database # # Input: # tag - the tag # value - the value to set # Output: # # sub DB_settingsSet { my ($tag, $value, undef) = @_; my $sql; my $sth; $sql = "replace into settings (tag, value) values (?, ?)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $tag, SQL_VARCHAR ); $sth->bind_param( 2, $value, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; return; } # # DB_settingsDelete # # Convenience routine to delete a setting from the database # # Input: # tag - the tag # Output: # # sub DB_settingsDelete { my ($tag, undef) = @_; my $value; my $sql; my $sth; $sql = "delete from settings where tag = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $tag, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->finish(); $DBH->commit(); undef $sth; return; } # # DB_prune # # Convenience routine to prune the database of old # or obsolete content. # # Input: # # Output: # # sub DB_prune { return if (!defined($DBH)); my $sql; my $sth; my $rc; my $expireBeforeDateTime = DateTime->now(time_zone => 'UTC')->subtract(days => 1); my $expireAfterDateTime = DateTime->now(time_zone => 'UTC')->add(days => 30); # Update any lineups where the downloaded datetime is in the future (bad rtc?) $sql = "update lineups set downloaded = '1970-01-01 00:00:00' where downloaded > ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $nowDateTimeSQLite, SQL_DATETIME ); $sth->execute(); if ($sth->err) { print (STDERR "Unable to update lineups with downloaded dates in the future in database: " . $sth->errstr . "\n"); } # Update any lineups where the modified datetime is in the future (bad rtc?) $sql = "update lineups set modified = '1970-01-01 00:00:00' where modified > ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $nowDateTimeSQLite, SQL_DATETIME ); $sth->execute(); if ($sth->err) { print (STDERR "Unable to update linesups with modified dates in the future in database: " . $sth->errstr . "\n"); } # Delete channels no longer in any of our lineups $sql = "delete from channels where lineup not in (select distinct lineups.lineup from lineups as lineups)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune channels no longer in our lineups in database: " . $sth->errstr . "\n"); } # Delete stations no longer in any of our channels $sql = "delete from stations where station not in (select distinct channels.station from channels as channels)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune stations no longer in our channels in database: " . $sth->errstr . "\n"); } # Delete schedules no longer referenced by our stations $sql = "delete from schedules where station not in (select distinct stations.station from stations as stations)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune schedules no longer associated with stations in database: " . $sth->errstr . "\n"); } # Delete schedules which have "expired" $sql = "delete from schedules where day < ? OR day > ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, DateTime::Format::SQLite->format_date($expireBeforeDateTime), SQL_DATE ); $sth->bind_param( 2, DateTime::Format::SQLite->format_date($expireAfterDateTime), SQL_DATE ); $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune schedules for past and far future dates in database: " . $sth->errstr . "\n"); } # Delete schedules_hash no longer referenced by our stations $sql = "delete from schedules_hash where station not in (select distinct stations.station from stations as stations)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune schedules_hash not associated with a station in database: " . $sth->errstr . "\n"); } # Delete schedules_hash which have "expired" $sql = "delete from schedules_hash where day < ? OR day > ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, DateTime::Format::SQLite->format_date($expireBeforeDateTime), SQL_DATE ); $sth->bind_param( 2, DateTime::Format::SQLite->format_date($expireAfterDateTime), SQL_DATE ); $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune schedules_hash for past and far future dates in database: " . $sth->errstr . "\n"); } # Delete schedules_hash which have no matching schedules $sql = "delete from schedules_hash where not exists (select * from schedules as schedules where schedules.station = schedules_hash.station and schedules.day = schedules_hash.day)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune schedules_hash which have no matching schedule in database: " . $sth->errstr . "\n"); } # Delete schedules for which there is no schedules_hash $sql = "delete from schedules where not exists (select * from schedules_hash as schedules_hash where schedules.station = schedules_hash.station and schedules.day = schedules_hash.day)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune schedules for unmatched schedule hashes in database: " . $sth->errstr . "\n"); } # Delete stations_schedules_hash no longer referenced by our stations $sql = "delete from stations_schedules_hash where station not in (select distinct channels.station from channels as channels)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune stations_schedules_hash in database: " . $sth->errstr . "\n"); } # Delete stations_schedules_hash which have "expired" $sql = "delete from stations_schedules_hash where day < ? OR day > ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, DateTime::Format::SQLite->format_date($expireBeforeDateTime), SQL_DATE ); $sth->bind_param( 2, DateTime::Format::SQLite->format_date($expireAfterDateTime), SQL_DATE ); $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune stations_schedules_hash for past and far future dates in database: " . $sth->errstr . "\n"); } # Delete programs no longer referenced by a schedule and are not supplemental $sql = "delete from programs where program not in (select distinct schedules.program from schedules as schedules) and program not in (select distinct p2.program_supplemental from programs as p2 where p2.program_supplemental is not null)"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->execute(); if ($sth->err) { print (STDERR "Unable to prune programs no longer referenced in database: " . $sth->errstr . "\n"); } # Update programs which have a downloaded data in the future (bad rtc?) # (this should force a refresh of any supplemental programs downloaded with bad dates) $sql = "update programs set downloaded = '1970-01-01 00:00:00' where downloaded > ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $nowDateTimeSQLite, SQL_DATETIME ); $sth->execute(); if ($sth->err) { print (STDERR "Unable to update programs with downloaded dates in the future in database: " . $sth->errstr . "\n"); } $DBH->commit(); undef $sth; # # Because the database may not have the needed configuration # for incremental vacuum, we issue the command, but do not # check the results of the execution (it works, or not) # $DBH->{'AutoCommit'} = 1; $DBH->do('PRAGMA incremental_vacuum'); $DBH->{'AutoCommit'} = 0; # # vacuum can be a resource intensive activity, so we do # not perform it by default. Incremental vacuum will # handle the low hanging fruit, and users can choose # to perform a full vacuum as desired # #$DBH->{'AutoCommit'} = 1; #$sql = "vacuum"; #$rc = $DBH->do($sql); #if ((!defined($rc)) || ($rc < 0)) # { # print (STDERR "Unable to prune programs in database: " . $DBH->errstr . "\n"); # } #$DBH->{'AutoCommit'} = 0; # # In many (real world) runs, substantive data has been # added/deleted/updated, so inform sqlite to consider # updating the database statistics for future query # planner activity. # $DBH->{'AutoCommit'} = 1; $DBH->do('PRAGMA optimize'); $DBH->{'AutoCommit'} = 0; return; } # # DB_clean # # Convenience routine to clean the database of all data # (commonly used to force a complete download) # # Input: # # Output: # # sub DB_clean { return if (!defined($DBH)); my $sql; my $rc; # # We do not delete the lineups, channels, or stations in order to try to # preserve any channel (de)selection that may have occurred. By setting # the downloaded and modified dates to long ago, we will refresh those. # # $sql = "delete from lineups"; # $rc = $DBH->do($sql); # if ((!defined($rc)) || ($rc < 0)) # { # print (STDERR "Unable to delete lineups in database: " . $DBH->errstr . "\n"); # exit(1); # } # $sql = "delete from channels"; # $rc = $DBH->do($sql); # if ((!defined($rc)) || ($rc < 0)) # { # print (STDERR "Unable to delete channels in database: " . $DBH->errstr . "\n"); # exit(1); # } # $sql = "delete from stations"; # $rc = $DBH->do($sql); # if ((!defined($rc)) || ($rc < 0)) # { # print (STDERR "Unable to delete stations in database: " . $DBH->errstr . "\n"); # exit(1); # } # $sql = "update lineups set downloaded = '1970-01-01 00:00:00', modified = '1970-01-01 00:00:00'"; $rc = $DBH->do($sql); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to update lineups in database: " . $DBH->errstr . "\n"); exit(1); } $sql = "delete from stations_schedules_hash"; $rc = $DBH->do($sql); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to delete stations_schedules_hash in database: " . $DBH->errstr . "\n"); exit(1); } $sql = "delete from schedules_hash"; $rc = $DBH->do($sql); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to delete schedules_hash in database: " . $DBH->errstr . "\n"); exit(1); } $sql = "delete from schedules"; $rc = $DBH->do($sql); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to delete schedules in database: " . $DBH->errstr . "\n"); exit(1); } $sql = "delete from programs"; $rc = $DBH->do($sql); if ((!defined($rc)) || ($rc < 0)) { print (STDERR "Unable to delete programs in database: " . $DBH->errstr . "\n"); exit(1); } $DBH->commit(); return; } # # manageLineups # # NOTE: This should not be in this grabber, but there # is no obvious alternative place to provide it.... # # The username/passwordhash is obtained from the # database if it exists (and can be opened) but # the lineup can be managed without a database # # Input: # # Output: # # sub manageLineups { my $username; my $passwordhash; my $pswdhash; my $token; if ((defined($conf->{'database'}->[0])) && (-f $conf->{'database'}->[0])) { DB_open($conf->{'database'}->[0]); $username = DB_settingsGet('username'); $passwordhash = DB_settingsGet('passwordhash'); $pswdhash = $passwordHash || $passwordhash; $token = DB_settingsGet('token') if (!defined($passwordHash)); } # Try obtained username/password, but allow re-entry my $auth_prompted = 0; while(1) { if (!defined($username)) { $username = ask("Enter your username at Schedules Direct:"); $pswdhash = undef; $auth_prompted = 1; } if (!defined($pswdhash)) { my $password = ask_password("Enter your password for $username at Schedules Direct:"); $pswdhash = sha1_hex($password); $auth_prompted = 1; } last if (defined($token = $SD->obtainToken($username, undef, $pswdhash, $token))); print (STDERR "Unable to authenticate to Schedules Direct: " . $SD->ErrorString() . "\n"); $username = undef; $passwordhash = undef; $pswdhash = undef; $token = undef; $auth_prompted = 1; } if ((defined($DBH)) && (!$auth_prompted) && (defined($token)) && (defined($passwordhash)) && (!defined($passwordHash))) { DB_settingsSet('token', $token); $DBH->commit(); } if (!defined($SD->obtainStatus())) { print (STDERR "Unable to obtain the service status at Schedules Direct: " . $SD->ErrorString() . "\n"); exit(1); } if (!$SD->isOnline) { print (STDERR "The Schedules Direct service is not currently online, Try again later.\n"); exit(1); } my $prompt = ''; my $choice = ''; my @choices = (); while ($choice ne 'Exit') { my $lineups = $SD->obtainLineups(); if (!defined($lineups)) { print (STDERR "Fatal error obtaining lineups: " . $SD->ErrorString() . "\n"); print (STDERR "Please re-run $SCRIPT_NAME --manage-lineups and/or $SCRIPT_NAME --configure\n"); exit(1); } $prompt .= "\n"; $prompt .= "Your Schedules Direct account has the following lineups configured:\n"; $prompt .= "Lineup ID Description\n"; $prompt .= "======================================================================\n"; for my $l (@{$lineups}) { next if ((ref($l) ne 'HASH') || (!defined($l->{'lineupID'}))); my $lineupDesc = ''; if (defined($l->{'isDeleted'}) && $l->{'isDeleted'}) { $lineupDesc = "DELETED LINEUP"; } else { $lineupDesc = lineupDesc($l->{'name'}, $l->{'transport'}, $l->{'location'}); } $prompt .= sprintf("%-20s %s\n", $l->{'lineupID'}, $lineupDesc); } $prompt .= "Specify a Schedules Direct account lineup management action"; @choices = ( [ 'Exit', 'Exit lineup management'] , [ 'Add', 'Add an additional lineup to your account' ], [ 'Delete', 'Delete an existing lineup from your account' ], [ 'Display Password Hash', 'Display your password hash'], [ 'Delete Password Hash', 'Delete any password hash stored in the database'], [ 'Initialize Database' , 'Initialize/update the local database'], [ 'Channel Selection', 'Manage database lineup channel selection'], ); $choice = askChoice($prompt, undef, @choices); $choice = 'Exit' if (!defined($choice)); $prompt = "\n"; if ($choice eq 'Add') { my $guided = ask_boolean("\nDo you want to use guided lineup addition?",1); next if (!defined($guided)); if (!$guided) { my $lineup_to_add = ask("\nEnter the Schedules Direct lineup to add: "); next if (!defined($lineup_to_add)); $lineup_to_add =~ s/^\s+|\s+$//g; if ($lineup_to_add eq '') { $prompt .= "No lineup entered to add\n"; next; } if ($SD->addLineup($lineup_to_add)) { $prompt .= "Lineup $lineup_to_add added\n"; } else { $prompt .= "Lineup addition of $lineup_to_add failed: " . $SD->ErrorString() . "\n"; } next; } # Obtain the list of countries (by region) my $available = $SD->obtainAvailable('COUNTRIES'); if ((!defined($available)) || (ref($available) ne 'HASH') || (scalar($available) == 0)) { $prompt .= "Regions are not available\n"; next; } @choices = (); foreach my $reg (sort(keys(%{$available}))) { push (@choices, ["$reg", "$reg"]); } my $region = askChoice("\nSelect the region for the new lineup (ctrl-D to skip)", undef, @choices); next if (!defined($region)); my @choices = (); my $clist = $available->{$region}; if (!defined($clist)) { $prompt .= "Region $region is ill-formed\n"; next; } if (scalar(@{$clist}) == 0) { $prompt .= "Region $region has no countries defined\n"; next; } for (my $i = 0; $i < scalar(@{$clist}); $i++) { next if ((!defined(@{$clist}[$i]->{'shortName'})) || (!defined(@{$clist}[$i]->{'fullName'}))); push (@choices, [$i, "@{$clist}[$i]->{'shortName'} - @{$clist}[$i]->{'fullName'}"]); } if (scalar(@choices) == 0) { $prompt .= "Region $region countries are improperly defined, no valid entries exist\n"; next; } my $cindex = askChoice("\nSelect the country code for the new lineup (ctrl-D to skip)", undef, @choices); next if (!defined($cindex)); # check if we can offer transmitter selection my $transmitters = $SD->obtainAvailable('DVB-T', '/' . @{$clist}[$cindex]->{'shortName'}); if (defined($transmitters) && (ref($transmitters) eq 'HASH') && (scalar($transmitters) != 0)) { my $selectXMTR = ask_boolean("\nDo you want to select by transmitter?",0); next if (!defined($selectXMTR)); if ($selectXMTR) { my @choices = (); my $aprompt = ''; foreach my $location(sort(keys(%{$transmitters}))) { my $lineup = $transmitters->{$location}; if (scalar(@choices) < 10) { push (@choices, [ "$lineup", sprintf (" %-20s %s", $lineup, "$location") ]); } else { push (@choices, [ "$lineup", sprintf ("%-20s %s", $lineup, "$location") ]); } } $aprompt = "\n"; $aprompt .= "Select one of the following lineups to add to your Schedules Direct account (ctrl-D to skip)\n"; $aprompt .= " Lineup ID Description\n"; $aprompt .= " ======================================================================\n"; my $lineup_to_add = askChoice($aprompt, undef, @choices); next if (!defined($lineup_to_add)); if ($SD->addLineup($lineup_to_add)) { $prompt .= "Lineup $lineup_to_add added\n"; } else { $prompt .= "Lineup addition of $lineup_to_add failed: " . $SD->ErrorString() . "\n"; } next; } } my $country_code = @{$clist}[$cindex]->{'shortName'}; my $postal_code_regex = @{$clist}[$cindex]->{'postalCode'}; $postal_code_regex =~ s/^\/(.*)\/[a-z]*$/\^$1\$/; # Adjust for perl my $postal_code_example = @{$clist}[$cindex]->{'postalCodeExample'}; my $postal_code_required = 1; $postal_code_required = !(@{$clist}[$cindex]->{'onePostalCode'}) if (defined(@{$clist}[$cindex]->{'onePostalCode'})); my $postal_code = ''; if ($postal_code_required) { my $pprompt = ''; while ((defined($postal_code) && ($postal_code eq ''))) { $pprompt .= "\nSpecify the postal code for the new lineup (ex: $postal_code_example) (ctrl-D to skip)"; $postal_code = ask($pprompt); $pprompt = ''; if (defined($postal_code)) { $postal_code =~ s/^\s+|\s+$//g; # Check regex (removed due bad regex's in /available) #if ("$postal_code" !~ m/$postal_code_regex/) # { # $pprompt .= "The specified postal code is not valid\n"; # $postal_code = ''; # } } } next if (!defined($postal_code)); } else { $postal_code = $postal_code_example; } my $availablelineups = $SD->obtainLineupsAvailable($country_code, $postal_code); if (!defined($availablelineups)) { print (STDERR "Fatal error obtaining available lineups: " . $SD->ErrorString() . "\n"); exit(1); } if ((ref($availablelineups) ne 'ARRAY') || (scalar(@{$availablelineups})) == 0) { $prompt .= "Unable to add lineup, Schedules Direct has no lineups in $country_code/$postal_code\n"; } else { my @choices = (); my $aprompt = ''; for my $l (@{$availablelineups}) { next if ((ref($l) ne 'HASH') || (!defined($l->{'lineupID'})) || ($l->{'lineupID'} eq '')); my $lineup = $l->{'lineupID'}; my $lineupDesc = lineupDesc($l->{'name'}, $l->{'transport'}, $l->{'location'}); if (scalar(@choices) < 10) { push (@choices, [ $lineup, sprintf (" %-20s %s", $lineup, $lineupDesc) ]); } else { push (@choices, [ $lineup, sprintf ("%-20s %s", $lineup, $lineupDesc) ]); } } $aprompt = "\n"; $aprompt .= "Select one of the following lineups to add to your Schedules Direct account (ctrl-D to skip)\n"; $aprompt .= " Lineup ID Description\n"; $aprompt .= " ======================================================================\n"; my $lineup_to_add = askChoice($aprompt, undef, @choices); next if (!defined($lineup_to_add)); if ($SD->addLineup($lineup_to_add)) { $prompt .= "Lineup $lineup_to_add added\n"; } else { $prompt .= "Lineup addition of $lineup_to_add failed: " . $SD->ErrorString() . "\n"; } } } elsif ($choice eq 'Delete') { if (scalar(@{$lineups}) == 0) { $prompt .= "No lineups available to delete\n"; next; } my @choices = (); for my $l (@{$lineups}) { my $lineupDesc = ''; if (defined($l->{'isDeleted'}) && $l->{'isDeleted'}) { $lineupDesc = "DELETED LINEUP"; } else { $lineupDesc = lineupDesc($l->{'name'}, $l->{'transport'}, $l->{'location'}); } push (@choices, [ $l->{'lineupID'}, sprintf("%-20s %s", $l->{'lineupID'}, $lineupDesc) ]);; } my $lineup_to_delete = askChoice("\nLineup to delete (ctrl-D to skip)", undef, @choices); next if (!defined($lineup_to_delete)); if ($SD->deleteLineup($lineup_to_delete)) { $prompt .= "Lineup $lineup_to_delete deleted\n"; } else { $prompt .= "Lineup deletion of $lineup_to_delete failed: " . $SD->ErrorString() . "\n"; } } elsif ($choice eq 'Display Password Hash') { $prompt .= "Your password hash is: $pswdhash\n"; } elsif ($choice eq 'Delete Password Hash') { if (!defined($DBH)) { $prompt .= "No database available, unable to delete any stored password hash\n"; } else { DB_settingsDelete('passwordhash'); DB_settingsDelete('token'); $prompt .= "Password hash deleted from the database\n"; } } elsif ($choice eq 'Initialize Database') { if (!defined($DBH)) { my $db = $conf->{'database'}->[0] || File::HomeDir->my_home . "/.xmltv/SchedulesDirect.DB"; my $newdb = ask("\nEnter your database[$db]:"); $db = $newdb if ($newdb ne ''); DB_open($db); $prompt .= "Database initialized.\n"; } DB_settingsSet('username', $username); my $storehash = ask_boolean( "\n" . "*WARNING* While your password is stored as a sha1 hash,\n" . "(i.e. the actual password is not stored in the database)\n" . "the sha1 hash can be used to update your schedules direct\n" . "lineup information, and since the sha1 hash is unsalted,\n" . "a poor password can easily be brute forced (or more likely\n" . "found in an existing online rainbow table). Ensure that\n" . "your database is appropriately protected. Note that it is\n" . "STRONGLY recommended that your Schedules Direct password\n" . "be a long random sequence of characters that is not shared\n" . "with any other service. If you choose not to store the\n" . "passwordhash in the database, you will need to specify it\n" . "at every invokation of the grabber.\n\n" . "Confirm that you want to store the passwordhash in the database", 1); $storehash = 0 if (!defined($storehash)); if ($storehash) { DB_settingsSet('passwordhash', $pswdhash); $prompt .= "Schedules Direct username/passwordhash stored in database\n"; } else { DB_settingsDelete('passwordhash'); DB_settingsDelete('token'); $prompt .= "Schedules Direct username stored in database\n"; } $DBH->commit(); } elsif ($choice eq 'Channel Selection') { if (!defined($DBH)) { $prompt .= "Database has not been initialized (or cannot be opened)\n"; next; } if (scalar(@{$lineups}) == 0) { $prompt .= "No lineups available to manage channels\n"; next; } my $choice = ''; my @choices = (); my $sql; my $sth; my $lineup; my $prompt = ''; @choices = (); for my $l (@{$lineups}) { my $lineupDesc = lineupDesc($l->{'name'}, $l->{'transport'}, $l->{'location'}); push (@choices, [ $l->{'lineupID'}, sprintf("%-20s %s", $l->{'lineupID'}, $lineupDesc) ]);; } $lineup = askChoice("\nLineup to manage channels (ctrl-D to skip)", undef, @choices); next if (!defined($lineup)); SD_downloadLineupMaps($lineup); while ($choice ne 'Exit') { $prompt .= "\nSelect lineup channel action for lineup $lineup:"; @choices = ( [ 'Exit', 'Exit lineup channel management'] , [ 'MarkFuture', 'Set future new or updated lineup channels as selected' ], [ 'ClearFuture', 'Set future new or updated lineup channels as unselected'], [ 'MarkExisting', 'Set all existing lineup channels as selected'], [ 'ClearExisting', 'Set all existing lineup channels as unselected'], [ 'Select', 'Choose which channels are selected'], ); $choice = askChoice($prompt, undef, @choices); $choice = 'Exit' if (!defined($choice)); $prompt = "\n"; # Changing selected values needs to force downloads # (it may not always be necessary, but it is the # only way to make sure) $sql = "update lineups set downloaded = '1970-01-01 00:00:00', modified = '1970-01-01' where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); if ($choice eq 'MarkFuture') { $sql = "update lineups set new_channels_selected = 1 where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); $prompt .= "Future channels set as selected\n"; } elsif ($choice eq 'ClearFuture') { $sql = "update lineups set new_channels_selected = 0 where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); $prompt .= "Future channels set as not selected\n"; } elsif ($choice eq 'MarkExisting') { $sql = "update channels set selected = 1 where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); $prompt .= "Existing channels set as selected\n"; } elsif ($choice eq 'ClearExisting') { $sql = "update channels set selected = 0 where lineup = ?"; $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); $prompt .= "Existing channels set as not selected\n"; } elsif ($choice eq 'Select') { # # two by two, hands of blue # my $sql = "select channels.rowid, channels.station, channels.channum, channels.selected, channels.details, stations.details from channels as channels left join stations as stations on stations.station = channels.station where channels.lineup = ? order by channels.station"; my $sth = $DBH->prepare_cached($sql); if (!defined($sth)) { print (STDERR "Unexpected error when preparing statement ($sql): " . $DBH->errstr . "\n"); exit(1); } my $sqlupd = "update channels set selected = ? where rowid = ?"; my $sthupd = $DBH->prepare_cached($sqlupd); if (!defined($sthupd)) { print (STDERR "Unexpected error when preparing statement ($sqlupd): " . $DBH->errstr . "\n"); exit(1); } $sth->bind_param( 1, $lineup, SQL_VARCHAR ); $sth->execute(); if ($sth->err) { print (STDERR "Unexpected database error when executing statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $sth->bind_col( 1, undef, SQL_INTEGER ); $sth->bind_col( 2, undef, SQL_VARCHAR ); $sth->bind_col( 3, undef, SQL_VARCHAR ); $sth->bind_col( 4, undef, SQL_INTEGER ); $sth->bind_col( 5, undef, SQL_VARCHAR ); $sth->bind_col( 6, undef, SQL_VARCHAR ); my $channelsSelect = $sth->fetchall_arrayref(); if ($sth->err()) { print (STDERR "Unexpected error when executing fetch after execute of statement ($sql): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); undef $sth; foreach my $channelSelect(@{$channelsSelect}) { my $rowid = $channelSelect->[0]; my $station = $channelSelect->[1]; my $channum = $channelSelect->[2]; my $selected = $channelSelect->[3]; my $cdetails = $channelSelect->[4]; my $sdetails = $channelSelect->[5]; my $c = eval { $JSON->decode($cdetails) } || {}; my $s = eval { $JSON->decode($sdetails) } || {}; my $name; $name = $s->{'name'} if (defined($s->{'name'})); my $callsign; $callsign = $s->{'callsign'} if (defined($s->{'callsign'})); my $i = ''; $i .= "$channum " if ($channum ne ''); $i .= "$name " if (defined($name)); $i .= "$callsign " if (defined($callsign)); if ($i eq '') { $i = 'Unknown'; } my $ans = ask_boolean($i, $selected); $ans = $selected if (!defined($ans)); $sthupd->bind_param( 1, $ans, SQL_INTEGER ); $sthupd->bind_param( 2, $rowid, SQL_VARCHAR ); $sthupd->execute(); if ($sthupd->err) { print (STDERR "Unexpected database error when executing statement ($sqlupd): " . $sth->errstr . "\n"); $DBH->rollback(); exit(1); } $DBH->commit(); } } } } } return; } # # generateRFC2838 # # Per the XMLTV definition, the station must be # in RFC2838 format, even though there are no # (realistic) tables that provide any consistent # or reliable mappings (for at least NA stations). # So, we meet the definition by making up a # compliant name. # # Input: # name - the station name # Output: # RFC2838 - rfc2838 station name # sub generateRFC2838 { my ($station, undef) = @_; if ($RFC2838_COMPLIANT) { return (sprintf("I%s.json.schedulesdirect.org", $station)); } else { return ($station); } } # # generateXMLTV_NS # # Per the XMLTV definition, the xmltv_ns string has # two parts, the number (zero origin) and the total # separated by a '/' if the total exists. This routine # provides the formatting conversion. # # Input: # number - the base number # total - the total # Output: # xmltv_ns - the string representing the number/total # sub generateXMLTV_NS { my ($number, $total, undef) = @_; return '' if (!defined($number)); if ($number =~ /^\d+$/) { $number = $number - 1; if ($number >= 0) { return "$number" if (!defined($total)); if ($total =~ /^\d+$/) { $total = $total + 0; if ($total > 0) { return "$number / $total"; } } return "$number"; } } return ''; } # # addRole # # Add a role to the roles hash, eliminating duplicates # and treating an empty character as incomplete if # other (better?) character entries are provided later. # Note that (unfortunately), we have no way of knowing # which "character" is better if we get more than one # (and the same actor could be playing multiple roles), # so we just return them all. # # Input: # roles - existing $roles array # role - role to add # person - person to add to role # order - billing order # character - character being played # attributes - attributes # Output: # none - $roles array updated # sub addRole { my ($roles, $role, $person, $order, $character, $attributes, undef) = @_; return if (!defined($role)); return if (!defined($person)); return if (!defined($order)); return if ($order !~ /^\d+$/); my $ra = $roles->{$role}; return if (!defined($ra)); $character = '' if (!defined($character)); $attributes = {} if (!defined($attributes)); if (!defined($ra->{$person})) # Add person if we do not have them { $ra->{$person}->{'order'} = 0 + $order; $ra->{$person}->{'character'} = []; $ra->{$person}->{'attributes'} = $attributes; } # Merge attributes (no known case to merge, but plan ahead) $ra->{$person}->{'attributes'} = {%{$ra->{$person}->{'attributes'}}, %{$attributes}}; # Add characters to the list the actor is playing (if more than one) if ($character ne '') { foreach my $c(@{$ra->{$person}->{'character'}}) # Do not duplicate characters { return if ($c eq $character); } push(@{$ra->{$person}->{'character'}}, $character); } return; } # # mapTransport # # The XMLTV definition specifies the allowed transport # types. Schedules Direct has slightly different # transport types. Map the Schedules Direct type to # an XMLTV type. # # Input: # SDtype - Schedules Direct transport type # Ouput: # XMLTVtype - XMLTV transport type # sub mapTransport { my ($transport, undef) = @_; return 'Unknown' if (!defined($transport)); state $transportTypeMap = # Map for Schedules Direct transport to XMLTV type { 'DVB-C' => 'DTV', # DVB-C 'DVB-T' => 'DTV', # DVB-T 'DVB-S' => 'DTV', # DVB-S (should be STB?) 'Cable' => 'STB', # Cable (most use a STB?) 'Antenna' => 'DTV', # Antenna (US ATSC and/or analog) 'Satellite' => 'STB', # Satellite (most use a STB?) 'IPTV' => 'STB' # Schedules Direct IPTV is STB-like }; if (defined($transportTypeMap->{$transport})) { return($transportTypeMap->{$transport}); } return 'Unknown'; } # # mapRatingAgency # # Map the Schedules Direct rating agency to the expected # (short) name for MythTV. # # Input: # body - rating Body # rating - rating # Output: # body - rating Body (abbrev) # rating - rating (adjusted for VCHIP) sub mapRatingAgency { my ($body, $rating, undef) = @_; my $mappedBody = $body; my $mappedRating = $rating; # Maps partially derived from wikipedia and the wiki page located at # http://www.filmo.gs/wiki/Identifying-Film-Classification-Symbols, # based on the Schedules Direct rating agency names from sample data. # There are likely many missing country agencies. Updates welcome. state $bodyMap = { 'Australian Classification Board' => 'CB', 'British Board of Film Classification' => 'BBFC', 'USA Parental Rating' => 'VCHIP', 'Motion Picture Association' => 'MPAA', 'Motion Picture Association of America' => 'MPAA', 'Freiwillige Selbstkontrolle der Filmwirtschaft' => 'FSK', 'Film & Publication Board' => 'FPB', 'Manitoba Film Classification Board' => 'MFCB', 'B.C. Film Classification Office' => 'BCFCO', 'Saskatchewan Film and Video Classification Board' => 'SFVCB', 'Medietilsynet' => 'NMA', 'Departamento de Justiça, Classificação, Títulos e Qualificação' => 'ClassInd', 'Alberta\'s Film Classification Board' => 'AFR', 'Régie du cinéma' => 'RCQ', 'The Régie du cinéma' => 'RCQ', 'Ontario Film Review Board' => 'OFRB', 'Maritime Film Classification Board' => 'MFC', 'Canadian Parental Rating' => 'CHVRS', 'Conseil Supérieur de l\'Audiovisuel' => 'CSA', 'Dirección General de Radio, Televisión y Cinematografía' => 'RTC', 'Instituto de Cinematografía y de las Artes Visuales' => 'ICAA', 'Mediakasvatus- ja kuvaohjelmayksikkö' => 'MEKU', 'UK Content Provider' => 'UK', 'Centre national du cinéma et de l\'image animée' => 'CNC', 'Irish Film Classification Office' => 'IFCO', # Guess 'Statens filmgranskningsbyrå' => 'VET', # Guess 'Nemzeti Média- és Hirközlési Hatóság' => 'NMHH', # Guess 'Nederlands Instituut voor de Classificatie van Audiovisuele Media' => 'NICAM', # Guess 'Office of Film and Literature Classification' => 'OFLC', # Guess 'Board of Film Censors' => 'BFC', # Guess 'Korea Media Rating Board' => 'KMRB' # Guess }; if (defined($bodyMap->{$body})) { $mappedBody = $bodyMap->{$body}; } # # Special hack for the VCHIP rating, as currently the # Schedules Direct rating does not include the '-' # if (defined($mappedBody) && ($mappedBody eq 'VCHIP')) { # Currently, the USA Parental Rating does not include the '-'? if (defined($mappedRating) && (length($mappedRating) > 2) && (substr($mappedRating,2,1) ne '-')) { $mappedRating = (substr($mappedRating,0,2) . '-' . substr($mappedRating, 2)); } } return ($mappedBody, $mappedRating); } # # mapUSATSCChannelToFrequency # # Map the US FCC channel number to a transmission # frequency # # Input: # channel - the FCC channel # Output: # frequency - frequency in HZ # sub mapUSATSCChannelToFrequency { my ($channel, undef) = @_; $channel =~ s/^\s+|\s+$//g; # Remove any leading/trailing spaces if ($channel =~ m/^\d+$/) { $channel = 0 + $channel; } my $frequency; state $USATSCFrequenciesMap = # US ATSC frequencies { 2 => 57000000, 3 => 63000000, 4 => 69000000, 5 => 79000000, 6 => 85000000, 7 => 177000000, 8 => 183000000, 9 => 189000000, 10 => 195000000, 11 => 201000000, 12 => 207000000, 13 => 213000000, 14 => 473000000, 15 => 479000000, 16 => 485000000, 17 => 491000000, 18 => 497000000, 19 => 503000000, 20 => 509000000, 21 => 515000000, 22 => 521000000, 23 => 527000000, 24 => 533000000, 25 => 539000000, 26 => 545000000, 27 => 551000000, 28 => 557000000, 29 => 563000000, 30 => 569000000, 31 => 575000000, 32 => 581000000, 33 => 587000000, 34 => 593000000, 35 => 599000000, 36 => 605000000, 37 => 611000000, 38 => 617000000, 39 => 623000000, 40 => 629000000, 41 => 635000000, 42 => 641000000, 43 => 647000000, 44 => 653000000, 45 => 659000000, 46 => 665000000, 47 => 671000000, 48 => 677000000, 49 => 683000000, 50 => 689000000, 51 => 695000000 }; $frequency = $USATSCFrequenciesMap->{$channel} || '0'; return $frequency; } # # logoPriority # # Return the station logo priority based on # the configuration station-logo-order. # # Input: # stationLogo - the station logo hash # Output: # priority - the logo priority # sub logoPriority { my ($stationLogo, undef) = @_; my $source; my $category; # # Internal one-time priority mapping initialization # local *logoPriorityInit = sub { my $priority = {}; my $pnum = 9999; if (defined($conf->{'station-logo-order'}->[0])) { foreach my $o(split(',', $conf->{'station-logo-order'}->[0])) { $o =~ s/^\s+|\s+$//g; next if ($o eq ''); $priority->{$o} = $pnum--; } } return $priority; }; state $logoPrio = logoPriorityInit($conf); return 0 if (ref($stationLogo) ne 'HASH'); $source = $stationLogo->{'source'} || ''; $source =~ s/^\s+|\s+$//g; $category = $stationLogo->{'category'} || ''; $category =~ s/^\s+|\s+$//g; return $logoPrio->{"$source/$category"} || 0; } # # lineupDesc # # return a consistent description for a lineup # # Input: # name - the lineup name/short descr # transport - the lineup transport # location - the lineup location # Output: # lineupDesc - standard description # sub lineupDesc { my ($name, $transport, $location, undef) = @_; my $lineupDesc = ''; $name = '' if (!defined($name)); $transport = '' if (!defined($transport)); $location = '' if (!defined($location)); $name =~ s/^\s+|\s+$//g; $transport =~ s/^\s+|\s+$//g; $location =~ s/^\s+|\s+$//g; $name = '[UPSTREAM BUG: Open ticket with Schedules Direct regarding missing name for this lineup]' if ($name eq ''); $lineupDesc = $name; $lineupDesc = $lineupDesc . ' (' if (($transport ne '') || ($location ne '')); $lineupDesc = $lineupDesc . $transport if ($transport ne ''); $lineupDesc = $lineupDesc . ' ' if (($transport ne '') && ($location ne '')); $lineupDesc = $lineupDesc . $location if ($location ne ''); $lineupDesc = $lineupDesc . ')' if (($transport ne '') || ($location ne '')); return($lineupDesc); } # # A little info # =pod =head1 NAME tv_grab_zz_sdjson_sqlite - Grab TV and radio program listings from Schedules Direct (subscription required). =head1 SYNOPSIS tv_grab_zz_sdjson_sqlite --help tv_grab_zz_sdjson_sqlite --info tv_grab_zz_sdjson_sqlite --version tv_grab_zz_sdjson_sqlite --capabilities tv_grab_zz_sdjson_sqlite --description tv_grab_zz_sdjson_sqlite --manage-lineups [--config-file FILE] [--quiet] [--debug] [--passwordhash HASH] tv_grab_zz_sdjson_sqlite [--days N] [--offset N] [--config-file FILE] [--output FILE] [--quiet] [--debug] [--passwordhash HASH] [--resturl URL] [--routeto ROUTETO] tv_grab_zz_sdjson_sqlite --configure [--config-file FILE] [--quiet] [--debug] [--passwordhash HASH] [--resturl URL] [--routeto ROUTETO] tv_grab_zz_sdjson_sqlite --list-channels [--config-file FILE] [--output FILE] [--quiet] [--debug] [--passwordhash HASH] [--resturl URL] [--routeto ROUTETO] tv_grab_zz_sdjson_sqlite --list-lineups [--config-file FILE] [--output FILE] [--quiet] [--debug] [--passwordhash HASH] [--resturl URL] [--routeto ROUTETO] tv_grab_zz_sdjson_sqlite --get-lineup [--config-file FILE] [--output FILE] [--quiet] [--debug] [--passwordhash HASH] [--resturl URL] [--routeto ROUTETO] =head1 DESCRIPTION Output TV listings in XMLTV format for many locations available in North America (US/CA) and other selected countries internationally. The data comes from L and an account must be created on the Schedules Direct site in order to grab data. Refer to the Schedules Direct site for signup requirements and supported locations. This grabber uses a shared local database which allows for downloading only new/changed/updated information, and in the case of mixed OTA, Cable, and/or Satellite providers can substantially reduce the download times (as some data such as schedules and program details are commonly shared between sources in the same location). First, you must run B to manage the lineups available to your grabber configuration at the Schedules Direct service. Second, you must run B to choose which lineup this configuration will grab (this grabber will share the downloaded information for multiple lineups, and can substantially reduce the royal overheads in those cases). =head1 OPTIONS B<--manage-lineups> Perform Schedules Direct lineup management functions (adding/deleting lineups from your account, and creating the local EPG database). Managing lineups can be performed without a configuration file (it will prompt for the needed information) but if it exists, it will be used to obtain initial credentials. If you change your password at Schedules Direct, you will need to update the database (or display the new password hash) using --manage-lineups. B<--configure> Prompt for which lineup to download and write the configuration file. Note that one must run --manage-lineups first to create and initialize the database and configure lineups. B<--config-file FILE> Set the name of the configuration file, the default is B<~/.xmltv/tv_grab_zz_sdjson_sqlite.conf>. This is the file written by B<--configure> and read when grabbing. B<--output FILE> When grabbing, write output to FILE rather than standard output. B<--download-only> Perform a download of the data only (no output). B<--no-download> Do not download data, but use the existing contents of the local database. Since the code optimizes the data downloaded, this is nominally useful only in offline situations. B<--force-download> Deletes most existing local database data and forces a download of the data. If there is a suspicion that the data is corrupt (and not being automatically corrected), forcing a new download might be necessary. B<--days N> When grabbing, grab N days rather than all available days. B<--offset N> Start grabbing at today/now + N days. B<--quiet> Suppress various informational messages shown on standard error. B<--debug> Provide more information on progress to stderr to help in debugging. This can get very verbose, but too much data is better that not enough if errors need to be squashed. Note that the debug data may contain information you might prefer to be confidential such as your password hash, so treat the output appropriately. B<--passwordhash HASH> Provide the password hash on the command line. This is necessary if the hash is not stored in the database. B<--scale-download N> Scale the download chunks from the default sizes. A value of .5 would reduce the sizes of the chunks requested by half. The resulting number is bound between 1 and the max value. B<--resturl URL> Provide the Schedules Direct service endpoint URL. This is primarily useful for testing when directed by Schedules Direct staff. B<--routeto ROUTETO> Provide the Schedules Direct service endpoint RouteTo header. This is primarily useful for testing when directed by Schedules Direct staff. B<--list-channels> Write output giving elements for every channel available in the current configuration. B<--list-lineups> Write output giving list of available viewing regions. Note that list-lineups is not fully standardized, so the output is subject to change. B<--get-lineup> Write output giving elements for every channel available in the current lineup. Note that get-lineup is not fully standardized, so the output is subject to change. B<--capabilities> Show which capabilities the grabber supports. For more information, see L B<--version> Show the version of the grabber. B<--help> Print a help message and exit. B<--info> Print a help page and exit. =head1 INSTALLATION 1. First you must signup for an account at Schedules Direct. This is a paid service providing EPG data for North America and other selected countries. See L for signup requirements, and the countries served. 2. Second you need to configure the lineups that you will have access to using your account with this grabber. Run B to add your lineups and to initialize the database. 3. Third, you will need to configure this specific instance of the grabber to select the lineup to use. Run B. 4. (Optionally) run B to download and "fill" the local database copies of your data. In future runs, only updated information will be downloaded, and the local database will be pruned to delete old/obsolete information. =head1 USAGE All the normal XMLTV capabilities are included. Note that Schedules Direct only has data for a maximum of about 21 days, (although may be less for some channels) but the accuracy of the data at the end of the period tends to be poor. =head1 ERROR HANDLING If the grabber encounters a fatal error, it will write a message to STDERR and exit(1). Some errors are retriable, and the code performs retries. =head1 ENVIRONMENT VARIABLES The environment variable HOME can be set to change where configuration files are stored. All configuration is stored in $HOME/.xmltv/. On Windows, it might be necessary to set HOME to a path without spaces in it. The environment variable TV_GRAB_TARGET_APPLICATION_FIXUPS can be set to indicate that the grabber should apply fixups for applications that are not fully XMLTV compliant, or that are currently missing some specific functionality. The fixups can be combined by separating them with colons. Available fixups are NO_XMLTV_NS_TOTAL_SEASONS (do not include the total seasons in the generated xmltv_ns episode numbering), NO_PREVIOUSLY_SHOWN_ZONE_OFFSET (do not include the zone offset in previously-shown), and NO_STATION_LOGOS (do not include station logos in the output). The fixups are intended to be temporary until the application(s) can be updated. =head1 SUPPORTED CHANNELS Schedules Direct lineups should support all the channels from your provider or OTA antenna. If there are missing channels, or incorrect guide data, you should contact Schedules Direct to request updates. =head1 XMLTV VALIDATION B may report an error similar to: "Line 123 Duplicate channel-tag for 'I12345.json.schedulesdirect.org'" This is because at least some providers (typically Cable/Satellite, but sometimes OTA repeaters that you may have in your lineup) actually have the exact same station available on multiple channels. XMLTV does not like seeing the same station reported twice, even though the full display-name info does show that the channel number is different. This error can (should/must?) be ignored. =head1 XMLTV STATIONS vs CHANNELS XMLTV (despite a couple of proposals to update the specifications) has a legacy confusion regarding the differences between a "station", which is a supplier of content (programs) and schedules, and a "channel" which is method of delivery/transport. XMLTV uses the term where they likely should be using the term , because they deal with programming, not transport. Regardless, such a transition would be understandably be a challenge, and the lineup proposals to extend the capability to provide a mechanism to support "channels" has not progressed in years. This also results in a failing of the configuration capability which treats the selecting of content as being station based, which is not always the same thing as a (for example, for Cable providers, a "station" may be transmitted on many "channels" (perhaps in different resolutions), but an individual may only be authorized to receive some of the "channels"). One may want the "station" schedules and programs, but not to see the "channel" returned because they cannot tune it. =head1 CHANNEL SELECTION Due to the XMLTV interpretations of , this grabber implements its own "channel" (transport) selection mechanism (which parallels that on the Schedules Direct site). It is implemented within the --manage-lineups capability. The grabber defaults will result in all channels and stations associated with the lineup being written. In some cases it may be desired by some to limit the channels to a small subset of all available channels (the most common being a Cable or Satellite service which has billions and billions of channels, but you are subscribed to a significantly reduced programming tier, and your application does not have the ability to restrict the display/access to that large number of channels). There is just enough flexibility to allow one to confuse oneself some of the time. Note that while an effort is made to maintain the existing selection value when the lineup mapping (channels and stations) are updated, new or changed station assignments per channel will result in the lineup defaults being assigned to the new or updated channel. The lineup channel selection default can also be set for an existing lineup. Due to the potential of future surprises or confusion, if one can avoid using the channel selection capability one is likely better off. =head1 FAQs No FAQs yet.... =head1 DISCLAIMER The Schedules Direct service requires a subscription, and only allows for usage for personal use with approved open source projects. Refer to the Schedules Direct site for their requirements and how to sign up. =head1 AUTHOR Gary Buhrmaster. As with most tv_grabbers, documentation, ideas, and parts of the code may have been leveraged from other existing grabbers from the XMLTV-project. We stand on the shoulders of those that came before us. =head1 COPYRIGHT Copyright (c) 2016, 2017, 2018, 2022 Gary Buhrmaster This code is distributed under the GNU General Public License v2 (GPLv2) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License version 2 as published by the Free Software Foundation. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. =head1 SEE ALSO L. =cut ######################################################################## package SchedulesDirect v20141201.0.0; # # Public methods # # Debug - set/return debug value # RaiseError - set/return croak value # PrintError - set/return carp value # Error - return error value # ErrorString - return error string value # RESTUrl - set/return the SD RESTUrl # Username - set/return username to use # Password - set/return passwordhash to use # PasswordHash - set/return passwordhash to use # Token - set/return SD Token to use # obtainToken - obtain and return SD token # obtainStatus - obtain and return SD status # isOnline - return true if SD systems online # accountExpiry - return account expiration datetime # obtainDataLastUpdated - return data last updated datetime # addLineup - add lineup to account # deleteLineup - delete lineup from account # obtainLineups - return lineups in account # obtainLineupMaps - return maps for lineup # obtainLineupsAvailable - return lineups available in country/postal # obtainStationsSchedules - return stations schedules # obtainStationsSchedulesHash - return stations schedules hash # obtainPrograms - return program data for programs # obtainAvailable - return available counties/satellites # deleteMessage - delete message # uriResolve - convert uri to absolute # require 5.016; use feature ':5.16'; use strict; use warnings FATAL => 'all'; use warnings NONFATAL => qw(exec recursion internal malloc newline deprecated portable); no warnings 'once'; use Carp; use Digest::SHA qw(sha1 sha1_hex sha1_base64); use URI; use URI::Escape; use Compress::Zlib; use HTTP::Request; use HTTP::Message; use JSON; use LWP::UserAgent::Determined; use LWP::Simple; use LWP::Protocol::https; use LWP::ConnCache; use Time::HiRes qw( time ); use Data::Dumper; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {@_}; $self->{'Username'} = undef unless $self->{'Username'}; $self->{'PasswordHash'} = undef unless $self->{'PasswordHash'}; $self->{'PasswordHash'} = sha1_hex($self->{'Password'}) if defined($self->{'Password'}); delete $self->{'Password'}; $self->{'UserAgent'} = 'tv_grab_zz_sdjson_sqlite' unless $self->{'UserAgent'}; $self->{'Debug'} = 0 unless $self->{'Debug'}; $self->{'RESTUrl'} = 'https://json.schedulesdirect.org/20141201' unless $self->{'RESTUrl'}; $self->{'RouteTo'} = undef unless $self->{'RouteTo'}; $self->{'RaiseError'} = 0 unless $self->{'RaiseError'}; # Not (yet) implemented $self->{'PrintError'} = 0 unless $self->{'PrintError'}; # Not (yet) implemented $self->{'_Token'} = undef; $self->{'_TokenAcquired'} = 0; # Refresh token every 20 hours $self->{'_TokenValidated'} = 0; if (defined($self->{'Token'})) { my ($token, $acquired) = split(' ', $self->{'Token'}, 2); if (defined($token) && ($token =~ /^[0-9A-Fa-f]+$/) && defined($acquired) && ($acquired =~ /^-?\d+\.?\d*$/)) { $self->{'_Token'} = $token; $self->{'_TokenAcquired'} = $acquired; } } delete $self->{'Token'}; $self->{'_Error'} = 0; $self->{'_ErrorString'} = ''; $self->{'_Status'} = undef; $self->{'_StatusAcquired'} = 0; # Refresh status every 15 minutes? $self->{'_JSON'} = JSON->new()->shrink(1)->utf8(1); $self->{'ConnCache'} = 10 unless $self->{'ConnCache'}; $self->{'_LWP'} = LWP::UserAgent::Determined->new(agent => $self->{'UserAgent'}, conn_cache => LWP::ConnCache->new(total_capacity => $self->{'ConnCache'})); $self->{'_LWP'}->timing('1,2,5,10,20,20,20,20,20,20'); $self->{'_LWP'}->requests_redirectable(['GET', 'HEAD', 'POST', 'PUT', 'DELETE']); $self->{'_LWP'}->default_header('Accept-Encoding' => scalar HTTP::Message::decodable(), 'Accept' => 'application/json', 'Content-Type' => 'application/json', 'Pragma' => 'no-cache', 'Cache-Control' => 'no-cache'); if (defined($self->{'RouteTo'})) { $self->{'_LWP'}->default_headers->header('RouteTo' => $self->{'RouteTo'}); } bless($self, $class); return $self; } END { } sub DESTROY { my $self = shift; return; } # # Convenience method since many times you only # need to know if Schedules Direct is 'online'. # sub isOnline { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); my $return; $self->_resetError; $self->obtainStatus; if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (defined($self->{'_Status'}->{'systemStatus'}->[0]->{'status'})) { my $status = $self->{'_Status'}->{'systemStatus'}->[0]->{'status'}; if ($status eq 'Online') { $return = 1; } else { $return = 0; } print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Unable to obtain the Schedules Direct system status"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Convenience method for when the account expires # sub accountExpiry { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); my $return; $self->_resetError; $self->obtainStatus; if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (defined($self->{'_Status'}->{'account'}->{'expires'})) { $return = $self->{'_Status'}->{'account'}->{'expires'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Unable to obtain the Schedules Direct account expiration date"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Convenience method to obtain when the data was last updated # sub obtainDataLastUpdated { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); my $return; $self->_resetError; $self->obtainStatus; if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (defined($self->{'_Status'}->{'lastDataUpdate'})) { $return = $self->{'_Status'}->{'lastDataUpdate'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $self->_setErrorString("Unable to obtain the Schedules Direct data last updated"); $return = undef; $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Return error # sub Error { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); my $return; $return = $self->{'_Error'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Return error string # sub ErrorString { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); my $return; $return = $self->{'_ErrorString'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return debug status # sub Debug { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); $self->_resetError; if (@_) { $self->{'Debug'} = shift } my $return = $self->{'Debug'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return RaiseError (croak) status # sub RaiseError { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { $self->{'RaiseError'} = shift } $return = $self->{'RaiseError'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return PrintError (carp) status # sub PrintError { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { $self->{'PrintError'} = shift } $return = $self->{'PrintError'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return username # sub Username { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { $self->{'Username'} = shift; $self->_resetSession; } $return = $self->{'Username'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return password (return hash) # sub Password { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { my $p = shift; $self->{'PasswordHash'} = sha1_hex($p); $self->_resetSession; } $return = $self->{'PasswordHash'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return password hash # sub PasswordHash { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { $self->{'PasswordHash'} = shift; $self->_resetSession; } $return = $self->{'PasswordHash'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return RESTUrl # sub RESTUrl { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { $self->{'RESTUrl'} = shift; $self->_resetSession; } $return = $self->{'RESTUrl'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return RouteTo # sub RouteTo { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { $self->{'RouteTo'} = shift; $self->{'_LWP'}->default_headers->remove_header('RouteTo'); if (defined($self->{'RouteTo'})) { $self->{'_LWP'}->default_headers->header('RouteTo' => $self->{'RouteTo'}); } $self->_resetSession; } $return = $self->{'RouteTo'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # set/return the (extended) SDToken # sub Token { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->_resetError; if (@_) { $self->_resetSession; my $t = shift; if (defined($t)) { my ($token, $acquired) = split(' ', $t, 2); if (defined($token) && ($token =~ /^[0-9A-Fa-f]+$/) && defined($acquired) && ($acquired =~ /^-?\d+\.?\d*$/)) { $self->{'_Token'} = $token; $self->{'_TokenAcquired'} = $acquired; $self->{'_TokenValidated'} = 0; } } } if (defined($self->{'_Token'})) { $return = "$self->{'_Token'} $self->{'_TokenAcquired'}"; } else { $return = undef; } print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Resolve a possible relative uri to absolute URL # sub uriResolve { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $uri = shift; my $path = shift || ''; my $return; $self->_resetError; $return = URI->new_abs( $uri, "$self->{'RESTUrl'}" . $path . "/" )->as_string(); print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Delete a message # sub deleteMessage { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my $messageID = shift; $self->_resetError; if (!defined($messageID)) { $return = 0; $self->_setErrorString("messageID is not specified to delete"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!$self->isOnline) { if ($self->{'_Error'}) { $return = 0; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 0; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(DELETE => "$self->{'RESTUrl'}/messages/$messageID"); $request->header(Token => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = 0; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = 0; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = 0; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = 0; $self->_setErrorString("HTTP response content was not parseable ($responseContent)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $code = $r->{'code'}; my $msg = $r->{'message'} || ''; if (!defined($code)) { $return = 0; $self->_setErrorString("Delete response was not valid"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($code != 0) { $return = 0; $self->_setError($code); $self->_setErrorString("Delete request failed, code: $code, message: $msg"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 1; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Add a lineup to the account # sub addLineup { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my $lineup = shift; $self->_resetError; if (!defined($lineup)) { $return = 0; $self->_setErrorString("Lineup is not specified to add"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!$self->isOnline) { if ($self->{'_Error'}) { $return = 0; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 0; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # After add (success or failure) make sure we get a new Status $self->{'_Status'} = undef; my $request = HTTP::Request->new(PUT => "$self->{'RESTUrl'}/lineups/$lineup"); $request->header(Token => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if (($responseCode == 403) || ($responseCode == 400)) { if (defined($responseContent)) { my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (defined($r)) { $self->_setError($r->{'code'}) if (defined($r->{'code'})); my $msg = $r->{'message'} || "(no message text returned for code)"; $self->_setErrorString("$msg"); $return = 0; $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 0; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 0; $self->_setErrorString("HTTP response content could not be decoded for response code $responseCode"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseCode != 200) { $return = 0; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = 9; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = 0; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = 0; $self->_setErrorString("HTTP response content was not parseable ($responseContent)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $code = $r->{'code'}; my $msg = $r->{'message'} || ''; if (!defined($code)) { $return = 0; $self->_setErrorString("Add lineup response was not valid (code not returned)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($code != 0) { $return = 0; $self->_setError($code); $self->_setErrorString("Add lineup request failed with code: $code, message: $msg"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 1; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Delete a lineup from the account # sub deleteLineup { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my $lineup = shift; $self->_resetError; if (!defined($lineup)) { $return = 0; $self->_setErrorString("Lineup is not specified to delete"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!$self->isOnline) { if ($self->{'_Error'}) { $return = 0; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 0; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # After delete (success or failure) make sure we get a new Status $self->{'_Status'} = undef; my $request = HTTP::Request->new(DELETE => "$self->{'RESTUrl'}/lineups/$lineup"); $request->header(Token => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = 0; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = 0; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = 0; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = 0; $self->_setErrorString("HTTP response content was not parseable ($responseContent)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $code = $r->{'code'}; my $msg = $r->{'message'} || ''; if (!defined($code)) { $return = 0; $self->_setErrorString("Delete response was not valid"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($code != 0) { $return = 0; $self->_setError($code); $self->_setErrorString("Delete request failed, code: $code, message: $msg"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = 1; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Obtain the lineups in the account # sub obtainLineups { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); my $return; $self->_resetError; if (!$self->isOnline) { if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(GET => "$self->{'RESTUrl'}/lineups"); $request->header('Token' => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode == 400) { # (bug?) Rather than returning an empty array, SD returns 400 error # We will convert this to an empty array (no lineups) if (defined($responseContent)) { my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (defined($r) && defined($r->{'code'}) && ($r->{'code'} == 4102)) { $return = []; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful: $responseCode"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (ref($r) ne 'HASH') { $return = undef; $self->_setErrorString("HTTP response content was not a hash: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($r->{'lineups'})) { $return = undef; $self->_setErrorString("HTTP response content was not a hash containing a lineup entity: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (ref($r->{'lineups'}) ne 'ARRAY') { $return = undef; $self->_setErrorString("HTTP response content was not a hash containing the lineup array: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = $r->{'lineups'}; for my $e(@{$return}) { next if (!defined($e->{'lineup'})); $e->{'lineupID'} = delete $e->{'lineup'}; } if ((ref($self->{'_Status'}) eq 'HASH') && (defined($self->{'_Status'}->{'lineups'})) && (ref($self->{'_Status'}->{'lineups'}) eq 'ARRAY')) { for my $e(@{$return}) { next if (!defined($e->{'lineupID'})); for my $se(@{$self->{'_Status'}->{'lineups'}}) { if ((ref($se) eq 'HASH') && (defined($se->{'lineup'})) && ($se->{'lineup'} eq $e->{'lineupID'}) && (defined($se->{'modified'}))) { $e->{'modified'} = $se->{'modified'}; last; } } } } print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # ObtainLineupMaps # sub obtainLineupMaps { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my $lineup = shift; $self->_resetError; if (!defined($lineup)) { $return = undef; $self->_setErrorString("Schedules Direct lineup not specified"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!$self->isOnline) { if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(GET => "$self->{'RESTUrl'}/lineups/$lineup"); $request->header('Token' => "$self->{'_Token'}", 'verboseMap' => 'true'); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable ($responseContent)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = $r; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # Return list of lineups available in country/postal code # sub obtainLineupsAvailable { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my ($country, $postalcode, undef) = @_; $self->_resetError; if (!defined($country) || ($country eq '')) { $return = undef; $self->_setErrorString("Country code not provided for lineup list"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($postalcode) || ($postalcode eq '')) { $return = undef; $self->_setErrorString("Postal code code not provided for lineup list"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!$self->isOnline) { if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $country = uri_escape($country); $postalcode = uri_escape($postalcode); my $request = HTTP::Request->new(GET => "$self->{'RESTUrl'}/headends?country=$country\&postalcode=$postalcode"); $request->header(Token => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode == 400) { # (bug?) Rather than returning an empty array, SD returns error # we will convert this to an empty array my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (defined($r)) { my $code = $r->{'code'}; my $msg = $r->{'message'} || ''; if (defined($code)) { $self->_setError($code); if ($code == 2102) { $return = []; $self->_setErrorString("No lineups in specified country/postalcode"); print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Error obtaining lineups ($code): $msg"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } } $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable ($responseContent)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (ref($r) ne 'ARRAY') { $return = undef; $self->_setErrorString("HTTP response content was not an array ($responseContent)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = []; for my $e(@{$r}) { next if ((ref($e) ne 'HASH') || (!defined($e->{'lineups'}))); my $lineups = $e->{'lineups'}; next if (ref($lineups) ne 'ARRAY'); for my $lu(@{$lineups}) { my $el = {}; next if ((ref($lu) ne 'HASH') || (!defined($lu->{'lineup'}))); $el->{'lineupID'} = $lu->{'lineup'}; $el->{'transport'} = $e->{'transport'} if (defined($e->{'transport'})); $el->{'location'} = $e->{'location'} if (defined($e->{'location'})); $el->{'name'} = $lu->{'name'} if (defined($lu->{'name'})); $el->{'uri'} = $lu->{'uri'} if (defined($lu->{'uri'})); push(@{$return}, $el); } } print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # obtainPrograms # sub obtainPrograms { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my (@programs) = @_; $self->_resetError; if (!$self->isOnline) { if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (scalar(@programs) == 0) { $return = []; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(POST => "$self->{'RESTUrl'}/programs"); $request->header('Token' => "$self->{'_Token'}"); $request->content($self->{'_JSON'}->encode(\@programs)); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->convert_blessed->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = $r; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # obtainStationsSchedules # sub obtainStationsSchedules { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my (@schedulesRequest) = @_; $self->_resetError; if (!$self->isOnline) { if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (scalar(@schedulesRequest) == 0) { $return = []; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(POST => "$self->{'RESTUrl'}/schedules"); $request->content($self->{'_JSON'}->encode(\@schedulesRequest)); $request->header('Token' => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->convert_blessed->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (ref($r) ne 'ARRAY') { $return = undef; $self->_setErrorString("HTTP response content was malformed (not an array)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } foreach my $e(@{$r}) { if (ref($e) ne 'HASH') { $return = undef; $self->_setErrorString("HTTP response content was malformed (not an array of hashes)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $hash = $e->{'metadata'}->{'md5'}; my $startDate = $e->{'metadata'}->{'startDate'}; my $modified = $e->{'metadata'}->{'modified'}; $e->{'MD5'} = $hash if (defined($hash)); $e->{'date'} = $startDate if (defined($startDate)); $e->{'modified'} = $modified if (defined($modified)); if ((defined($hash)) && (defined($startDate)) && (defined($modified))) { $e->{'code'} = 0 if (!defined($e->{'code'})); $e->{'message'} = 'OK' if (!defined($e->{'message'})); $e->{'response'} = 'OK' if (!defined($e->{'response'})); } delete $e->{'metadata'}; } $return = $r; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # obtainStationsSchedulesHash # sub obtainStationsSchedulesHash { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my (@stationsRequest) = @_; $self->_resetError; if (!$self->isOnline) { if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(POST => "$self->{'RESTUrl'}/schedules/md5"); $request->content($self->{'_JSON'}->encode(\@stationsRequest)); $request->header('Token' => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->convert_blessed->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (ref($r) ne 'HASH') { $return = undef; $self->_setErrorString("HTTP response content was not a hash: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = []; for my $station(keys %{$r}) { if (ref($r->{$station}) eq 'HASH') { for my $date(keys %{$r->{$station}}) { my $e = {}; $e->{'stationID'} = $station; $e->{'date'} = $date; $e->{'code'} = $r->{$station}->{$date}->{'code'} if (defined($r->{$station}->{$date}->{'code'})); $e->{'MD5'} = $r->{$station}->{$date}->{'md5'} if (defined($r->{$station}->{$date}->{'md5'})); $e->{'message'} = $r->{$station}->{$date}->{'message'} if (defined($r->{$station}->{$date}->{'message'})); $e->{'lastModified'} = $r->{$station}->{$date}->{'lastModified'} if (defined($r->{$station}->{$date}->{'lastModified'})); $e->{'response'} = "OK" if ($r->{$station}->{$date}->{'code'} eq 0); push(@{$return}, $e); } } } print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # obtainAvailable # sub obtainAvailable { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my $type = shift; my $path = shift; $type = '' if (!defined($type)); $path = '' if (!defined($path)); $self->_resetError; if (!$self->isOnline) { if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("Schedules Direct web services is not online"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (($path ne '') && ($type eq '')) { $return = undef; $self->_setErrorString("obtainAvailable request is not valid (type=$type, path=$path)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(GET => "$self->{'RESTUrl'}/available"); $request->header('Token' => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->convert_blessed->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($type eq '') { $return = $r; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (ref($r) ne 'ARRAY') { $return = undef; $self->_setErrorString("HTTP response content was malformed (not an array)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } foreach my $e(@{$r}) { if (ref($e) ne 'HASH') { $return = undef; $self->_setErrorString("HTTP response content was malformed (not an array of hashes)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (defined($e->{'type'}) && ($e->{'type'} eq "$type")) { if (defined($e->{'uri'})) { my $uri = $e->{'uri'}; $uri =~ s/\/\{.*?\}$//; # Bad adjustment? $request = HTTP::Request->new(GET => $self->uriResolve($uri) . "$path"); $request->header('Token' => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); $responseCode = $response->code(); $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $r = eval { $self->{'_JSON'}->convert_blessed->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = $r; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } else { $return = undef; $self->_setErrorString("HTTP response content was malformed (uri not specified in available response)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } } } $return = undef; $self->_setErrorString("HTTP response did not match type=$type"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # obtainStatus # sub obtainStatus { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); my $return; $self->_resetError; $self->obtainToken; if ($self->{'_Error'}) { $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $now = time(); #Reuse existing status if in current session and last status update < 15 min ago if (defined($self->{'_Status'}) && ($self->{'_StatusAcquired'} > ($now - 900))) { print (STDERR "DEBUG: (re)using current status\n") if ($self->{'Debug'}); $return = $self->{'_Status'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $self->{'_Status'} = undef; my $request = HTTP::Request->new(GET => "$self->{'RESTUrl'}/status"); $request->header('Token' => "$self->{'_Token'}"); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode != 200) { $self->_setErrorString("HTTP response code was not successful ($responseCode)"); $self->_CroakOrCarp; $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $code = $r->{'code'}; my $message = $r->{'message'} || '' ; if (!defined($code) || !defined($message)) { $self->_setErrorString("Schedules Direct status request response was not valid: $responseContent"); $self->_CroakOrCarp; $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (($code != 0)) { $self->_setError($code); $self->_setErrorString("Schedules Direct status request response message: $message ($code)"); $self->_CroakOrCarp; $return = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $self->{'_Status'} = $r; $self->{'_StatusAcquired'} = $now; $return = $r; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } # # obtainToken # sub obtainToken { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; my ($username, $password, $passwordHash, $existingtoken, undef) = @_; $self->_resetError; my $now = time(); $self->Username($username) if defined($username); $self->Password($password) if defined($password); $self->PasswordHash($passwordHash) if defined($passwordHash); $self->Token($existingtoken) if defined($existingtoken); # Reuse existing token if available, acquired < 20 hours ago, and validated or we can validate if (defined($self->{'_Token'}) && ($self->{'_TokenAcquired'} > ($now - 72000))) { if ($self->{'_TokenValidated'}) { print (STDERR "DEBUG: (re)using current token\n") if ($self->{'Debug'}); $return = $self->Token; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } else { # Try a status request to validate provided token print (STDERR "DEBUG: attempting to validate token\n") if ($self->{'Debug'}); $self->{'_TokenValidated'} = 1; # Avoid infinite recursion by presuming success $self->obtainStatus; if ($self->{'_Error'}) { $self->{'_TokenValidated'} = 0; print (STDERR "DEBUG: unable to validate token, will attempt to obtain a new token\n") if ($self->{'Debug'}); } else { print (STDERR "DEBUG: using validated token\n") if ($self->{'Debug'}); $return = $self->Token; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } } } $self->_resetSession; $self->_resetError; if (!defined($self->{'Username'})) { $return = undef; $self->_setErrorString("Username not provided for obtaining Schedules Direct token"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($self->{'PasswordHash'})) { $return = undef; $self->_setErrorString("Password not provided for obtaining Schedules Direct token"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $request = HTTP::Request->new(POST => "$self->{'RESTUrl'}/token"); my %json_data = ("username" => $self->{'Username'}, "password" => $self->{'PasswordHash'}); $request->content($self->{'_JSON'}->encode(\%json_data)); print (STDERR "DEBUG: HTTP request:\n" . Data::Dumper->new([$request])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $response = $self->{'_LWP'}->request($request); print (STDERR "DEBUG: HTTP response:\n" . Data::Dumper->new([$response])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $responseCode = $response->code(); my $responseContent = $response->decoded_content(); print (STDERR "DEBUG: HTTP decoded response content:\n" . Data::Dumper->new([$responseContent])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); if ($responseCode == 400) { if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded for response code 400"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty for response code 400."); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not valid JSON for response code 400: $responseContent)"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $code = $r->{'code'}; my $message = $r->{'message'}; if (!defined($code) || !defined($message)) { $return = undef; $self->_setErrorString("Schedules Direct authorization token response was not valid 400: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (($code != 0) || ("$message" ne "OK")) { $return = undef; $self->_setErrorString("Schedules Direct authorization token request code: $code, message: $message"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $return = undef; $self->_setErrorString("HTTP response code and content inconsistent for code 400: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseCode != 200) { $return = undef; $self->_setErrorString("HTTP response code was $responseCode"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($responseContent)) { $return = undef; $self->_setErrorString("HTTP response content could not be decoded"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if ($responseContent eq '') { $return = undef; $self->_setErrorString("HTTP response content was empty"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $r = eval { $self->{'_JSON'}->decode($responseContent) }; if (!defined($r)) { $return = undef; $self->_setErrorString("HTTP response content was not parseable: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } my $code = $r->{'code'}; my $message = $r->{'message'}; my $token = $r->{'token'}; if (!defined($code) || !defined($message)) { $return = undef; $self->_setErrorString("Schedules Direct authorization token response was not valid: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (($code != 0) || ("$message" ne "OK")) { $return = undef; $self->_setError($code); $self->_setErrorString("Schedules Direct authorization token response code: $code, message: $message"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } if (!defined($token)) { $return = undef; $self->_setErrorString("Schedules Direct authorization token was not returned: $responseContent"); $self->_CroakOrCarp; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } $self->{'_Token'} = $token; $self->{'_TokenAcquired'} = $now; $self->{'_TokenValidated'} = 1; $return = $self->Token; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } sub _resetError { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); $self->{'_Error'} = 0; $self->{'_ErrorString'} = ''; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . "\n") if ($self->{'Debug'}); return; } sub _setError { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; if (@_) { $self->{'_Error'} = shift || (-1) } $return = $self->{'_Error'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } sub _setErrorString { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . " with args: \n" . Data::Dumper->new(\@_)->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); my $return; $self->{'_Error'} = (-1) if (!defined($self->{'_Error'}) || $self->{'_Error'} == 0); if (@_) { $self->{'_ErrorString'} = shift || '' } $return = $self->{'_ErrorString'}; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . " with: \n" . Data::Dumper->new([$return])->Pad('DEBUG: ')->Useqq(1)->Dump) if ($self->{'Debug'}); return $return; } sub _resetSession { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); $self->{'_Token'} = undef; $self->{'_TokenAcquired'} = 0; $self->{'_TokenValidated'} = 0; $self->{'_Status'} = undef; print (STDERR "DEBUG: Returning from " . (caller(0))[3] . "\n") if ($self->{'Debug'}); return; } sub _CroakOrCarp { my $self = shift; print (STDERR "DEBUG: Entering " . (caller(0))[3] . "\n") if ($self->{'Debug'}); if ($self->{'_Error'}) { if ($self->{'RaiseError'}) { Carp::croak($self->{'_ErrorString'}); } if ($self->{'PrintError'}) { Carp::carp($self->{'_ErrorString'}); } } print (STDERR "DEBUG: Returning from " . (caller(0))[3] . "\n") if ($self->{'Debug'}); return; } 1; # vim: set expandtab tabstop=2 shiftwidth=2 softtabstop=2 autoindent smartindent filetype=perl syntax=perl: