#!/usr/bin/perl
#
# get_iplayer - Lists, Records and Streams BBC iPlayer TV and Radio programmes + other Programmes via 3rd-party plugins
#
# Copyright (C) 2008-2010 Phil Lewis
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# 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, see .
#
# Author: Phil Lewis
# Email: iplayer2 (at sign) linuxcentre.net
# Web: http://linuxcentre.net/iplayer
# License: GPLv3 (see LICENSE.txt)
#
#
package main;
my $version = 2.80;
#
# Help:
# ./get_iplayer --help | --longhelp
#
# Changelog:
# http://linuxcentre.net/get_iplayer/CHANGELOG.txt
#
# Example Usage and Documentation:
# http://linuxcentre.net/getiplayer/documentation
#
# Todo:
# * Fix non-uk detection - iphone auth?
# * Index/Record live radio streams w/schedule feeds to assist timing
# * Remove all rtsp/mplayer/lame/tee dross when realaudio streams become obselete (not quite yet)
# ** all global vars into a class???
# ** Cut down 'use' clauses in each class
# * stdout streaming with mms
# * Add podcast links to web pvr manager
# * Add PVR search src to recording history
# * Fix unicode / wide chars in rdf
#
# Known Issues:
# * CAVEAT: The filenames and modes in the history are comma-separated if there was a multimode download. For now it just uses the first one.
#
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use File::Spec;
use Getopt::Long;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use POSIX qw(:termios_h);
use strict;
#use warnings;
use Time::Local;
use URI;
my %SIGORIG;
# Save default SIG actions
$SIGORIG{$_} = $SIG{$_} for keys %SIG;
$|=1;
# Hash of where plugin files were found so that the correct ones can be updated
my %plugin_files;
# Hash of all prog types => Programme class
# Add an entry here if another Programme class is added
my %prog_types = (
tv => 'Programme::tv',
radio => 'Programme::radio',
liveradio => 'Programme::liveradio',
livetv => 'Programme::livetv',
);
# Programme instance data
# $prog{$pid} = Programme->new (
# 'index' => ,
# 'name' => ,
# 'episode' => ,
# 'desc' => ,
# 'available' => ,
# 'duration' =>
# 'versions' =>
# 'thumbnail' =>
# 'channel =>
# 'categories' =>
# 'type' =>
# 'timeadded' =>
# 'version' =>
# 'filename' =>
# 'dir' =>
# 'fileprefix' =>
# 'ext' =>
#);
# Define general 'option names' => ( ,
$desc = $1 if $entry =~ m{
\s*(.*?)\s*
\s*};
# Remove unwanted html tags
$desc =~ s!?(br|b|i|p|strong)\s*/?>!!gi;
# Parse the categories into hash
#
my @category;
for my $line ( grep /{debug};
# Merge and Skip if this pid is a duplicate
if ( defined $prog->{$pid} ) {
main::logger "WARNING: '$pid, $prog->{$pid}->{name} - $prog->{$pid}->{episode}, $prog->{$pid}->{channel}' already exists (this channel = $channel)\n" if $opt->{verbose};
# Since we use the 'Signed' (or 'Audio Described') channel to get sign zone/audio described data, merge the categories from this entry to the existing entry
if ( $prog->{$pid}->{categories} ne join(',', sort @category) ) {
my %cats;
$cats{$_} = 1 for ( @category, split /,/, $prog->{$pid}->{categories} );
main::logger "INFO: Merged categories for $pid from $prog->{$pid}->{categories} to ".join(',', sort keys %cats)."\n" if $opt->{verbose};
$prog->{$pid}->{categories} = join(',', sort keys %cats);
}
# If this a popular or highlights programme then add these tags to categories
my %cats;
$cats{$_} = 1 for ( @category, split /,/, $prog->{$pid}->{categories} );
$cats{Popular} = 1 if $channel eq 'Popular';
$cats{Highlights} = 1 if $channel eq 'Highlights';
$prog->{$pid}->{categories} = join(',', sort keys %cats);
# If this is a dupicate pid and the channel is now Signed then both versions are available
$version = 'signed' if $channel eq 'Signed';
$version = 'audiodescribed' if $channel eq 'Audio Described';
# Add version to versions for existing prog
$prog->{$pid}->{versions} = join ',', main::make_array_unique_ordered( (split /,/, $prog->{$pid}->{versions}), $version );
next;
}
# Set guidance based on category
$guidance = 'Yes' if grep /guidance/i, @category;
# Check for signed-only or audiodescribed-only version from Channel
if ( $channel eq 'Signed' ) {
$version = 'signed';
} elsif ( $channel eq 'Audio Described' ) {
$version = 'audiodescribed';
} else {
$version = 'default';
}
# Default to 150px width thumbnail;
my $thumbsize = $opt->{thumbsizecache} || 150;
# build data structure
$prog->{$pid} = main::progclass($prog_type)->new(
'pid' => $pid,
'name' => $name,
'versions' => $version,
'episode' => $episode,
'seriesnum' => $seriesnum,
'episodenum' => $episodenum,
'desc' => $desc,
'guidance' => $guidance,
'available' => 'Unknown',
'duration' => 'Unknown',
'thumbnail' => "${thumbnail_prefix}/${pid}".Programme::bbciplayer->thumb_url_suffixes->{ $thumbsize },
'channel' => $channel,
'categories' => join(',', sort @category),
'type' => $prog_type,
'web' => "${bbc_prog_page_prefix}/${pid}.html",
);
}
}
# Get future schedules if required
# http://www.bbc.co.uk/cbbc/programmes/schedules/this_week.xml
# http://www.bbc.co.uk/cbbc/programmes/schedules/next_week.xml
if ( $opt->{refreshfuture} ) {
# Hack to get correct 'channels' method because this methods is being shared with Programme::radio
my %channels = %{ main::progclass($prog_type)->channels_filtered( main::progclass($prog_type)->channels_schedule() ) };
# Only get schedules for real channels
@channel_list = keys %channels;
for my $channel_id ( @channel_list ) {
my @schedule_feeds = (
"http://www.bbc.co.uk/${channel_id}/this_week.xml",
"http://www.bbc.co.uk/${channel_id}/next_week.xml",
);
for my $url ( @schedule_feeds ) {
main::logger "DEBUG: Getting feed $url\n" if $opt->{verbose};
$xml = main::request_url_retry($ua, $url, 3, '.', "WARNING: Failed to get programme schedule feed for $channel_id from iplayer site\n");
decode_entities($xml);
#
# 2010-01-11T11:25:00Z
# 2010-01-11T11:30:00Z
# 300
#
# b00l6wjs
# Vampire Bats
# How to survive the most dangerous
# situations that Mother Nature can chuck at
# you.
# A light-hearted look at how to survive
# the most dangerous situations that Mother Nature can
# chuck at you.
#
#
#
# 2010-01-18T11:29:00Z
#
# 16
#
# b00kh5x3
# Shorts
#
#
# b00kh5y8
# Sam and Mark's Guide to Dodging Disaster
#
#
#
# get list of entries within tags
my @entries = split //, $xml;
# Discard first element == header
shift @entries;
main::logger "INFO: Got ".($#entries + 1)." programmes\n" if $opt->{verbose};
my $now = time();
foreach my $entry (@entries) {
my ( $title, $channel, $name, $episode, $episodetitle, $nametitle, $seriestitle, $episodenum, $seriesnum, $desc, $pid, $available, $duration, $thumbnail, $version, $guidance );
my $entry_flat = $entry;
$entry_flat =~ s/\n/ /g;
$pid = $1 if $entry =~ m{.*?\s*(.+?)\s*};
$episode = $1 if $entry =~ m{.*?\s*(.*?)\s*};
$nametitle = $1 if $entry =~ m{.*?\s*(.*?)\s*.*?};
$seriestitle = $1 if $entry =~ m{.*?\s*(.*?)\s*.*?};
# Set name
if ( $nametitle && $seriestitle ) {
$name = "$nametitle: $seriestitle";
} elsif ( $seriestitle && ! $nametitle ) {
$name = $seriestitle;
# Fallback to episade name if the BBC missed out both Series and Name
} elsif ( ( ! $seriestitle ) && ! $nametitle ) {
$name = $episode;
} else {
$name = $nametitle;
}
# Extract the seriesnum
my $regex = 'Series\s+'.main::regex_numbers();
$seriesnum = main::convert_words_to_number( $1 ) if $seriestitle =~ m{$regex}i;
# Extract the episode num
my $regex_1 = 'Episode\s+'.main::regex_numbers();
my $regex_2 = '^'.main::regex_numbers().'\.\s+';
if ( $episode =~ m{$regex_1}i ) {
$episodenum = main::convert_words_to_number( $1 );
} elsif ( $episode =~ m{$regex_2}i ) {
$episodenum = main::convert_words_to_number( $1 );
}
# extract desc
if ( $entry =~ m{\s*(.+?)\s*} ) {
$desc = $1;
} elsif ( $entry =~ m{\s*(.+?)\s*} ) {
$desc = $1;
} elsif ( $entry =~ m{\s*(.+?)\s*} ) {
$desc = $1;
};
# Remove unwanted html tags
$desc =~ s!?(br|b|i|p|strong)\s*/?>!!gi;
$duration = $1 if $entry =~ m{\s*(.+?)\s*};
$available = $1 if $entry =~ m{\s*(.+?)\s*};
# Extract channel nice name
$channel = $channels{$channel_id};
main::logger "DEBUG: '$pid, $name - $episode, $channel'\n" if $opt->{debug};
# Merge and Skip if this pid is a duplicate
if ( defined $prog->{$pid} ) {
main::logger "WARNING: '$pid, $prog->{$pid}->{name} - $prog->{$pid}->{episode}, $prog->{$pid}->{channel}' already exists (this channel = $channel)\n" if $opt->{verbose};
# Update this info from schedule (not available in the usual iplayer channels feeds)
$prog->{$pid}->{duration} = $duration;
$prog->{$pid}->{episodenum} = $episodenum if ! $prog->{$pid}->{episodenum};
$prog->{$pid}->{seriesnum} = $seriesnum if ! $prog->{$pid}->{seriesnum};
# don't add this as some progs are already available
#$prog->{$pid}->{available} = $available;
next;
}
$version = 'default';
# Default to 150px width thumbnail;
my $thumbsize = $opt->{thumbsizecache} || 150;
# Don't create this prog instance if the availablity is in the past
# this prevents programmes which never appear in iPlayer from being indexed
next if Programme::get_time_string( $available ) < $now;
# build data structure
$prog->{$pid} = main::progclass($prog_type)->new(
'pid' => $pid,
'name' => $name,
'versions' => $version,
'episode' => $episode,
'seriesnum' => $seriesnum,
'episodenum' => $episodenum,
'desc' => $desc,
'available' => $available,
'duration' => $duration,
'thumbnail' => "${thumbnail_prefix}/${pid}".Programme::bbciplayer->thumb_url_suffixes->{ $thumbsize },
'channel' => $channel,
'type' => $prog_type,
'web' => "${bbc_prog_page_prefix}/${pid}.html",
);
}
}
}
}
main::logger "\n";
return 0;
}
# Usage: download (, , , , )
sub download {
my ( $prog, $ua, $mode, $version, $version_pid ) = ( @_ );
# Check if we need 'tee'
if ( $mode =~ /^real/ && (! main::exists_in_path('tee')) && $opt->{stdout} && (! $opt->{nowrite}) ) {
main::logger "\nERROR: tee does not exist in path, skipping\n";
return 'next';
}
if ( $mode =~ /^(real|wma)/ && (! main::exists_in_path('mplayer')) ) {
main::logger "\nWARNING: Required mplayer does not exist\n";
return 'next';
}
# Check if we have mplayer and lame
if ( $mode =~ /^real/ && (! $opt->{wav}) && (! $opt->{raw}) && (! main::exists_in_path('lame')) ) {
main::logger "\nWARNING: Required lame does not exist, will save file in wav format\n";
$opt->{wav} = 1;
}
# Check if we have vlc
if ( $mode =~ /^n95/ && (! main::exists_in_path('vlc')) ) {
main::logger "\nWARNING: Required vlc does not exist\n";
return 'next';
}
# if flvstreamer does not exist
if ( $mode =~ /^flash/ && ! main::exists_in_path('flvstreamer')) {
main::logger "WARNING: Required program flvstreamer does not exist (see http://linuxcentre.net/getiplayer/installation and http://linuxcentre.net/getiplayer/download)\n";
return 'next';
}
# Force raw mode if ffmpeg is not installed
if ( $mode =~ /^flash/ && ! main::exists_in_path('ffmpeg')) {
main::logger "\nWARNING: ffmpeg does not exist - not converting flv file\n";
$opt->{raw} = 1;
}
# Get extension from streamdata if defined and raw not specified
$prog->{ext} = $prog->{streams}->{$version}->{$mode}->{ext};
# Nasty hacky filename ext overrides based on non-default fallback modes
# Override iphone ext from metadata which is wrong for radio
$prog->{ext} = 'mp3' if $mode =~ /^iphone/ && $prog->{type} eq 'radio';
# Override realaudio ext based on raw / wav
$prog->{ext} = 'ra' if $opt->{raw} && $mode =~ /^real/;
$prog->{ext} = 'wav' if $opt->{wav} && $mode =~ /^real/;
# Override flash ext based on raw
$prog->{ext} = 'flv' if $opt->{raw} && $mode =~ /^flash/;
# Override flashaac ext based on aactomp3
$prog->{ext} = 'mp3' if ! $opt->{raw} && $opt->{aactomp3} && $mode =~ /^flashaac/;
# Override ext based on mkv option
$prog->{ext} = 'mkv' if ! $opt->{raw} && $opt->{mkv} && $prog->{type} eq 'tv';
# Determine the correct filenames for this recording
if ( $prog->generate_filenames( $ua, $prog->file_prefix_format() ) ) {
return 'skip';
}
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filename}) if $opt->{symlink};
# Create dir for prog if not streaming-only
if ( ( ! ( $opt->{stdout} && $opt->{nowrite} ) ) && ( ! $opt->{test} ) ) {
$prog->create_dir();
}
# Skip from here if we are only testing recordings
return 'skip' if $opt->{test};
# Get subtitles if they exist and are required
# best to do this before streaming file so that the subtitles can be enjoyed while recording progresses
my $subfile_done;
my $subfile;
if ( $opt->{subtitles} ) {
$subfile_done = "$prog->{dir}/$prog->{fileprefix}.srt";
$subfile = "$prog->{dir}/$prog->{fileprefix}.partial.srt";
main::logger "\n";
$prog->download_subtitles( $ua, $subfile );
}
my $return = 0;
# Only get the stream if we are writing a file or streaming
if ( $opt->{stdout} || ! $opt->{nowrite} ) {
# set mode
$prog->{mode} = $mode;
# Disable proxy here if required
main::proxy_disable($ua) if $opt->{partialproxy};
# Instantiate new streamer based on streamdata
my $class = "Streamer::$prog->{streams}->{$version}->{$mode}->{streamer}";
my $stream = $class->new;
# Do recording
$return = $stream->get( $ua, $prog->{streams}->{$version}->{$mode}->{streamurl}, $prog, %{ $prog->{streams}->{$version}->{$mode} } );
# Re-enable proxy here if required
main::proxy_enable($ua) if $opt->{partialproxy};
}
# Rename the subtitle file accordingly if the stream get was successful
move($subfile, $subfile_done) if $opt->{subtitles} && -f $subfile && ! $return;
return $return;
}
# BBC iPlayer TV
# Download Subtitles, convert to srt(SubRip) format and apply time offset
# Todo: get the subtitle streamurl before this...
sub download_subtitles {
my $prog = shift;
my ( $ua, $file ) = @_;
my $suburl;
my $subs;
# Don't redownload subs if the file already exists
if ( ( -f $file || -f "$prog->{dir}/$prog->{fileprefix}.partial.srt" ) && ! $opt->{overwrite} ) {
main::logger "INFO: Skipping subtitles download - file already exists: $file\n" if $opt->{verbose};
return 0;
}
$suburl = $prog->{streams}->{$prog->{version}}->{subtitles1}->{streamurl};
# Return if we have no url
if (! $suburl) {
main::logger "INFO: Subtitles not available\n";
return 2;
}
main::logger "INFO: Getting Subtitles from $suburl\n" if $opt->{verbose};
# Open subs file
unlink($file);
open( my $fh, "> $file" );
binmode $fh;
# Download subs
$subs = main::request_url_retry($ua, $suburl, 2);
if (! $subs ) {
main::logger "ERROR: Subtitle Download failed\n";
close $fh;
unlink($file) if -f $file;
return 1;
} else {
# Dump raw subs into a file if required
if ( $opt->{subsraw} ) {
unlink("$prog->{dir}/$prog->{fileprefix}.ttxt");
main::logger "INFO: 'Downloading Raw Subtitles to $prog->{dir}/$prog->{fileprefix}.ttxt'\n";
open( my $fhraw, "> $prog->{dir}/$prog->{fileprefix}.ttxt");
binmode $fhraw;
print $fhraw $subs;
close $fhraw;
}
main::logger "INFO: Downloading Subtitles to '$prog->{dir}/$prog->{fileprefix}.srt'\n";
}
# Convert the format to srt
# SRT:
#1
#00:01:22,490 --> 00:01:26,494
#Next round!
#
#2
#00:01:33,710 --> 00:01:37,714
#Now that we've moved to paradise, there's nothing to eat.
#
# TT:
#
Thinking.
#
You're thinking of Hamburger Hill... Since we left...
#
APPLAUSE AND CHEERING
my $count = 1;
my @lines = grep / elements
s|| |g;
# Remove >1 spaces
s|\s{2,}| |g;
( $begin, $end, $sub ) = ( $1, $2, $3 ) if m{
(.+?)<\/p>};
if ($begin && $end && $sub ) {
# Format numerical field widths
$begin = sprintf( '%02d:%02d:%02d,%02d', split /[:\.,]/, $begin );
$end = sprintf( '%02d:%02d:%02d,%02d', split /[:\.,]/, $end );
# Add trailing zero if ttxt format only uses hundreths of a second
$begin .= '0' if $begin =~ m{,\d\d$};
$end .= '0' if $end =~ m{,\d\d$};
if ($opt->{suboffset}) {
$begin = main::subtitle_offset( $begin, $opt->{suboffset} );
$end = main::subtitle_offset( $end, $opt->{suboffset} );
}
# Separate individual lines based on s
$sub =~ s|(.*?)|\n$1\n|g;
if ($sub =~ m{\n}) {
chomp($sub);
$sub =~ s|^\n?|- |;
$sub =~ s|\n+|\n- |g;
}
decode_entities($sub);
# Write to file
print $fh "$count\n";
print $fh "$begin --> $end\n";
print $fh "$sub\n\n";
$count++;
}
}
close $fh;
return 0;
}
################### Radio class #################
package Programme::radio;
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# Inherit from Programme class
use base 'Programme::bbciplayer';
# Class vars
sub index_min { return 10001 }
sub index_max { return 19999 };
sub channels {
return {
'bbc_1xtra' => 'BBC 1Xtra',
'bbc_radio_one' => 'BBC Radio 1',
'bbc_radio_two' => 'BBC Radio 2',
'bbc_radio_three' => 'BBC Radio 3',
'bbc_radio_four' => 'BBC Radio 4',
'bbc_radio_four_extra' => 'BBC Radio 4 Extra',
'bbc_radio_five_live' => 'BBC Radio 5 live',
'bbc_radio_five_live_sports_extra' => 'BBC 5 live Sports Extra',
'bbc_6music' => 'BBC 6 Music',
'bbc_7' => 'BBC 7',
'bbc_asian_network' => 'BBC Asian Network',
'bbc_radio_foyle' => 'BBC Radio Foyle',
'bbc_radio_scotland' => 'BBC Radio Scotland',
'bbc_radio_nan_gaidheal' => 'BBC Radio Nan Gaidheal',
'bbc_radio_ulster' => 'BBC Radio Ulster',
'bbc_radio_wales' => 'BBC Radio Wales',
'bbc_radio_cymru' => 'BBC Radio Cymru',
'bbc_world_service' => 'BBC World Service',
'bbc_radio_cumbria' => 'BBC Cumbria',
'bbc_radio_newcastle' => 'BBC Newcastle',
'bbc_tees' => 'BBC Tees',
'bbc_radio_lancashire' => 'BBC Lancashire',
'bbc_radio_merseyside' => 'BBC Merseyside',
'bbc_radio_manchester' => 'BBC Manchester',
'bbc_radio_leeds' => 'BBC Leeds',
'bbc_radio_sheffield' => 'BBC Sheffield',
'bbc_radio_york' => 'BBC York',
'bbc_radio_humberside' => 'BBC Humberside',
'bbc_radio_lincolnshire' => 'BBC Lincolnshire',
'bbc_radio_nottingham' => 'BBC Nottingham',
'bbc_radio_leicester' => 'BBC Leicester',
'bbc_radio_derby' => 'BBC Derby',
'bbc_radio_stoke' => 'BBC Stoke',
'bbc_radio_shropshire' => 'BBC Shropshire',
'bbc_wm' => 'BBC WM',
'bbc_radio_coventry_warwickshire' => 'BBC Coventry & Warwickshire',
'bbc_radio_hereford_worcester' => 'BBC Hereford & Worcester',
'bbc_radio_northampton' => 'BBC Northampton',
'bbc_three_counties_radio' => 'BBC Three Counties',
'bbc_radio_cambridge' => 'BBC Cambridgeshire',
'bbc_radio_norfolk' => 'BBC Norfolk',
'bbc_radio_suffolk' => 'BBC Suffolk',
'bbc_radio_essex' => 'BBC Essex',
'bbc_london' => 'BBC London',
'bbc_radio_kent' => 'BBC Kent',
'bbc_radio_surrey' => 'BBC Surrey',
'bbc_radio_sussex' => 'BBC Sussex',
'bbc_radio_oxford' => 'BBC Oxford',
'bbc_radio_berkshire' => 'BBC Berkshire',
'bbc_radio_solent' => 'BBC Solent',
'bbc_radio_gloucestershire' => 'BBC Gloucestershire',
'bbc_radio_wiltshire' => 'BBC Wiltshire',
'bbc_radio_bristol' => 'BBC Bristol',
'bbc_radio_somerset_sound' => 'BBC Somerset',
'bbc_radio_devon' => 'BBC Devon',
'bbc_radio_cornwall' => 'BBC Cornwall',
'bbc_radio_guernsey' => 'BBC Guernsey',
'bbc_radio_jersey' => 'BBC Jersey',
'popular/radio' => 'Popular',
'highlights/radio' => 'Highlights',
};
}
# channel ids be found on http://www.bbc.co.uk/bbcone/programmes/schedules/today
sub channels_schedule {
return {
'1xtra/programmes/schedules' => 'BBC 1Xtra',
'radio1/programmes/schedules/england' => 'BBC Radio 1 England',
'radio1/programmes/schedules/northernireland'=> 'BBC Radio 1 Northern Ireland',
'radio1/programmes/schedules/scotland' => 'BBC Radio 1 Scotland',
'radio1/programmes/schedules/wales' => 'BBC Radio 1 Wales',
'radio2/programmes/schedules' => 'BBC Radio 2',
'radio3/programmes/schedules' => 'BBC Radio 3',
'radio4/programmes/schedules/fm' => 'BBC Radio 4 FM',
'radio4/programmes/schedules/lw' => 'BBC Radio 4 LW',
'radio4extra/programmes/schedules' => 'BBC Radio 4 Extra',
'5live/programmes/schedules' => 'BBC Radio 5 live',
'5livesportsextra/programmes/schedules' => 'BBC 5 live Sports Extra',
'6music/programmes/schedules' => 'BBC 6 Music',
'radio7/programmes/schedules' => 'BBC 7',
'asiannetwork/programmes/schedules' => 'BBC Asian Network',
'radiofoyle/programmes/schedules' => 'BBC Radio Foyle',
'radioscotland/programmes/schedules/fm' => 'BBC Radio Scotland', # fm,mw,orkney,shetland,highlandsandislands
'radionangaidheal/programmes/schedules' => 'BBC Radio Nan Gaidheal',
'radioulster/programmes/schedules' => 'BBC Radio Ulster',
'radiowales/programmes/schedules/fm' => 'BBC Radio Wales FM',
'radiowales/programmes/schedules/mw' => 'BBC Radio Wales MW',
#'bbc_radio_cymru' => 'BBC Radio Cymru', # ????
'worldservice/programmes/schedules' => 'BBC World Service',
'cumbria/programmes/schedules' => 'BBC Cumbria',
'newcastle/programmes/schedules' => 'BBC Newcastle',
'tees/programmes/schedules' => 'BBC Tees',
'lancashire/programmes/schedules' => 'BBC Lancashire',
'merseyside/programmes/schedules' => 'BBC Merseyside',
'manchester/programmes/schedules' => 'BBC Manchester',
'leeds/programmes/schedules' => 'BBC Leeds',
'sheffield/programmes/schedules' => 'BBC Sheffield',
'york/programmes/schedules' => 'BBC York',
'humberside/programmes/schedules' => 'BBC Humberside',
'lincolnshire/programmes/schedules' => 'BBC Lincolnshire',
'nottingham/programmes/schedules' => 'BBC Nottingham',
'leicester/programmes/schedules' => 'BBC Leicester',
'derby/programmes/schedules' => 'BBC Derby',
'stoke/programmes/schedules' => 'BBC Stoke',
'shropshire/programmes/schedules' => 'BBC Shropshire',
'wm/programmes/schedules' => 'BBC WM',
'coventry/programmes/schedules' => 'BBC Coventry & Warwickshire',
'herefordandworcester/programmes/schedules'=> 'BBC Hereford & Worcester',
'northampton/programmes/schedules' => 'BBC Northampton',
'threecounties/programmes/schedules' => 'BBC Three Counties',
'cambridgeshire/programmes/schedules' => 'BBC Cambridgeshire',
'norfolk/programmes/schedules' => 'BBC Norfolk',
'suffolk/programmes/schedules' => 'BBC Suffolk',
'essex/programmes/schedules' => 'BBC Essex',
'london/programmes/schedules' => 'BBC London',
'kent/programmes/schedules' => 'BBC Kent',
'surrey/programmes/schedules' => 'BBC Surrey',
'sussex/programmes/schedules' => 'BBC Sussex',
'oxford/programmes/schedules' => 'BBC Oxford',
'berkshire/programmes/schedules' => 'BBC Berkshire',
'solent/programmes/schedules' => 'BBC Solent',
'gloucestershire/programmes/schedules' => 'BBC Gloucestershire',
'wiltshire/programmes/schedules' => 'BBC Wiltshire',
'bristol/programmes/schedules' => 'BBC Bristol',
'somerset/programmes/schedules' => 'BBC Somerset',
'devon/programmes/schedules' => 'BBC Devon',
'cornwall/programmes/schedules' => 'BBC Cornwall',
'guernsey/programmes/schedules' => 'BBC Guernsey',
'jersey/programmes/schedules' => 'BBC Jersey',
};
}
# Class cmdline Options
sub opt_format {
return {
radiomode => [ 1, "radiomode|amode=s", 'Recording', '--radiomode ,,...', "Radio Recording mode(s): iphone,flashaac,flashaachigh,flashaacstd,flashaaclow,flashaudio,realaudio,wma (default: flashaachigh,flashaacstd,flashaudio,realaudio,flashaaclow)"],
bandwidth => [ 1, "bandwidth=n", 'Recording', '--bandwidth', "In radio realaudio mode specify the link bandwidth in bps for rtsp streaming (default 512000)"],
lame => [ 0, "lame=s", 'External Program', '--lame ', "Location of lame binary"],
outputradio => [ 1, "outputradio=s", 'Output', '--outputradio ', "Output directory for radio recordings"],
wav => [ 1, "wav!", 'Recording', '--wav', "In radio realaudio mode output as wav and don't transcode to mp3"],
rtmpradioopts => [ 1, "rtmp-radio-opts|rtmpradioopts=s", 'Recording', '--rtmp-radio-opts ', "Add custom options to flvstreamer for radio"],
};
}
# This gets run before the download retry loop if this class type is selected
sub init {
# Force certain options for radio
# Force --raw otherwise realaudio stdout streaming fails
# (this would normally be a bad thing but since its a stdout stream we
# won't be downloading other types of progs afterwards)
$opt->{raw} = 1 if $opt->{stdout} && $opt->{nowrite};
}
# Method to return optional list_entry format
sub optional_list_entry_format {
my $prog = shift;
my @format;
for ( qw/ channel categories / ) {
push @format, $prog->{$_} if defined $prog->{$_};
}
return ', '.join ', ', @format;
}
# Default minimum expected download size for a programme type
sub min_download_size {
return 102400;
}
# Returns the modes to try for this prog type
sub modelist {
my $prog = shift;
my $mlist = $opt->{radiomode} || $opt->{modes};
# Defaults
if ( ! $mlist ) {
if ( ! main::exists_in_path('flvstreamer') ) {
main::logger "WARNING: Not using flash modes since flvstreamer is not found\n" if $opt->{verbose};
$mlist = 'rtspaudio,realaudio,wma';
} else {
$mlist = 'flashaachigh,flashaacstd,flashaudio,rtspaudio,realaudio,flashaaclow,wma';
}
}
# Deal with BBC Radio fallback modes and expansions
# Valid modes are iphone,rtmp,flashaac,flashaudio,realaudio,wmv
# 'rtmp' or 'flash' => 'flashaudio,flashaac'
# flashaac => flashaachigh,flashaacstd,flashaaclow
# flashaachigh => flashaachigh1,flashaachigh2
$mlist = main::expand_list($mlist, 'best', 'flashaachigh,flashaacstd,iphone,flashaudio,realaudio,flashaaclow,wma');
$mlist = main::expand_list($mlist, 'flash', 'flashaudio,flashaac');
$mlist = main::expand_list($mlist, 'rtmp', 'flashaudio,flashaac');
$mlist = main::expand_list($mlist, 'flashaac', 'flashaachigh,flashaacstd,flashaaclow');
return $mlist;
}
sub clean_pid {
my $prog = shift;
## extract [bpw]??????? format - remove surrounding url
#$prog->{pid} =~ s/^.+\/([bpw]\w{7})(\..+)?$/$1/g;
## Remove extra URL path for URLs like 'http://www.bbc.co.uk/iplayer/radio/bbc_radio_one'
#$prog->{pid} =~ s/^.+\/(.+?)\/?$/$1/g;
# If this is an iPlayer pid
if ( $prog->{pid} =~ m{^([bpw]0[a-z0-9]{6})$} ) {
# extract b??????? format from any URL containing it
$prog->{pid} = $1;
# If this is an iPlayer programme pid URL (and not on BBC programmes site)
} elsif ( $prog->{pid} =~ m{^http.+\/([bpw]0[a-z0-9]{6})\/?.*$} && $prog->{pid} !~ m{/programmes/} ) {
# extract b??????? format from any URL containing it
$prog->{pid} = $1;
# If this is a BBC *iPlayer* Live channel
#} elsif ( $prog->{pid} =~ m{http.+bbc\.co\.uk/iplayer/console/}i ) {
# # Just leave the URL as the pid
# e.g. http://www.bbc.co.uk/iplayer/playlive/bbc_radio_fourfm/
} elsif ( $prog->{pid} =~ m{http.+bbc\.co\.uk/iplayer}i ) {
# Remove extra URL path for URLs like 'http://www.bbc.co.uk/iplayer/playlive/bbc_radio_one/'
$prog->{pid} =~ s/^http.+\/(.+?)\/?$/$1/g;
# Else this is an embedded media player URL (live or otherwise)
} elsif ($prog->{pid} =~ m{^http}i ) {
# Just leave the URL as the pid
}
}
sub get_links {
shift;
# Delegate to Programme::tv (same function is used)
return Programme::tv->get_links(@_);
}
sub download {
# Delegate to Programme::tv (same function is used)
return Programme::tv::download(@_);
}
################### BBC Live Parent class #################
package Programme::bbclive;
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# Inherit from Programme class
use base 'Programme::bbciplayer';
# Class vars
sub file_prefix_format { '' }
# Class cmdline Options
sub opt_format {
return {};
}
# Method to return optional list_entry format
sub optional_list_entry_format {
return '';
}
sub clean_pid {
my $prog = shift;
# If this is a BBC *iPlayer* Live channel
#if ( $prog->{pid} =~ m{http.+bbc\.co\.uk/iplayer/console/}i ) {
# # Just leave the URL as the pid
# e.g. http://www.bbc.co.uk/iplayer/playlive/bbc_radio_fourfm/
if ( $prog->{pid} =~ m{http.+bbc\.co\.uk/iplayer}i ) {
# Remove extra URL path for URLs like 'http://www.bbc.co.uk/iplayer/playlive/bbc_radio_one/'
$prog->{pid} =~ s/^http.+\/(.+?)\/?$/$1/g;
# Else this is an embedded media player URL (live or otherwise)
} elsif ($prog->{pid} =~ m{^http}i ) {
# Just leave the URL as the pid
}
}
# Usage: Programme::liveradio->get_links( \%prog, 'liveradio' );
# Uses: %{ channels() }, \%prog
sub get_links {
shift; # ignore obj ref
my $prog = shift;
my $prog_type = shift;
# Hack to get correct 'channels' method because this methods is being shared with Programme::radio
my %channels = %{ main::progclass($prog_type)->channels_filtered( main::progclass($prog_type)->channels() ) };
for ( sort keys %channels ) {
# Extract channel
my $channel = $channels{$_};
my $pid = $_;
my $name = $channels{$_};
my $episode = 'live';
main::logger "DEBUG: '$pid, $name - $episode, $channel'\n" if $opt->{debug};
# build data structure
$prog->{$pid} = main::progclass($prog_type)->new(
'pid' => $pid,
'name' => $name,
'versions' => 'default',
'episode' => $episode,
'desc' => "Live stream of $name",
'guidance' => '',
#'thumbnail' => "http://static.bbc.co.uk/mobile/iplayer_widget/img/ident_${pid}.png",
'thumbnail' => "http://www.bbc.co.uk/iplayer/img/station_logos/${pid}.png",
'channel' => $channel,
#'categories' => join(',', @category),
'type' => $prog_type,
'web' => "http://www.bbc.co.uk/iplayer/playlive/${pid}/",
);
}
main::logger "\n";
return 0;
}
sub download {
# Delegate to Programme::tv (same function is used)
return Programme::tv::download(@_);
}
################### Live TV class #################
package Programme::livetv;
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# Inherit from Programme class
use base 'Programme::bbclive';
# Class vars
sub index_min { return 80000 }
sub index_max { return 80099 }
sub channels {
return {
'bbc_one' => 'BBC One',
'bbc_two' => 'BBC Two',
'bbc_three' => 'BBC Three',
'bbc_four' => 'BBC Four',
'cbbc' => 'CBBC',
'cbeebies' => 'CBeebies',
'bbc_news24' => 'BBC News 24',
'bbc_parliament' => 'BBC Parliament',
};
}
# Class cmdline Options
sub opt_format {
return {
livetvmode => [ 1, "livetvmode=s", 'Recording', '--livetvmode ,,...', "Live TV Recoding modes: flashhd,flashvhigh,flashhigh,flashstd,flashnormal (default: flashhd,flashvhigh,flashhigh,flashstd,flashnormal)"],
outputlivetv => [ 1, "outputlivetv=s", 'Output', '--outputlivetv ', "Output directory for live tv recordings"],
rtmplivetvopts => [ 1, "rtmp-livetv-opts|rtmplivetvopts=s", 'Recording', '--rtmp-livetv-opts ', "Add custom options to flvstreamer for livetv"],
};
}
# This gets run before the download retry loop if this class type is selected
sub init {
# Force certain options for Live
# Force only one try if live and recording to file
$opt->{attempts} = 1 if ( ! $opt->{attempts} ) && ( ! $opt->{nowrite} );
# Force to skip checking history if live
$opt->{force} = 1;
}
# Returns the modes to try for this prog type
sub modelist {
my $prog = shift;
my $mlist = $opt->{livetvmode} || $opt->{modes};
# Defaults
if ( ! $mlist ) {
$mlist = 'flashhd,flashvhigh,flashhigh,flashstd,flashnormal';
}
# Deal with BBC TV fallback modes and expansions
# Valid modes are rtmp,flashhigh,flashstd
# 'rtmp' or 'flash' => 'flashhigh,flashnormal'
$mlist = main::expand_list($mlist, 'best', 'flashhd,flashvhigh,flashhigh,flashstd,flashnormal,flashlow');
$mlist = main::expand_list($mlist, 'flash', 'flashhd,flashvhigh,flashhigh,flashstd,flashnormal,flashlow');
$mlist = main::expand_list($mlist, 'rtmp', 'flashhd,flashvhigh,flashhigh,flashstd,flashnormal,flashlow');
return $mlist;
}
# Default minimum expected download size for a programme type
sub min_download_size {
return 102400;
}
################### Live Radio class #################
package Programme::liveradio;
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# Inherit from Programme class
use base 'Programme::bbclive';
# Class vars
sub index_min { return 80100 }
sub index_max { return 80199 }
sub channels {
return {
'bbc_1xtra' => 'BBC 1Xtra',
'bbc_radio_one' => 'BBC Radio 1',
'bbc_radio_two' => 'BBC Radio 2',
'bbc_radio_three' => 'BBC Radio 3',
'bbc_radio_fourfm' => 'BBC Radio 4 FM',
'bbc_radio_fourlw' => 'BBC Radio 4 LW',
'bbc_radio_four_extra' => 'BBC Radio 4 Extra',
'bbc_radio_five_live' => 'BBC Radio 5 live',
'bbc_radio_five_live_sports_extra' => 'BBC 5 live Sports Extra',
'bbc_6music' => 'BBC 6 Music',
'bbc_7' => 'BBC 7',
'bbc_asian_network' => 'BBC Asian Network',
'bbc_radio_foyle' => 'BBC Radio Foyle',
'bbc_radio_scotland' => 'BBC Radio Scotland',
'bbc_radio_nan_gaidheal' => 'BBC Radio Nan Gaidheal',
'bbc_radio_ulster' => 'BBC Radio Ulster',
'bbc_radio_wales' => 'BBC Radio Wales',
'bbc_radio_cymru' => 'BBC Radio Cymru',
'http://www.bbc.co.uk/worldservice/includes/1024/screen/audio_console.shtml?stream=live' => 'BBC World Service',
'bbc_world_service' => 'BBC World Service Intl',
'bbc_radio_cumbria' => 'BBC Cumbria',
'bbc_radio_newcastle' => 'BBC Newcastle',
'bbc_tees' => 'BBC Tees',
'bbc_radio_lancashire' => 'BBC Lancashire',
'bbc_radio_merseyside' => 'BBC Merseyside',
'bbc_radio_manchester' => 'BBC Manchester',
'bbc_radio_leeds' => 'BBC Leeds',
'bbc_radio_sheffield' => 'BBC Sheffield',
'bbc_radio_york' => 'BBC York',
'bbc_radio_humberside' => 'BBC Humberside',
'bbc_radio_lincolnshire' => 'BBC Lincolnshire',
'bbc_radio_nottingham' => 'BBC Nottingham',
'bbc_radio_leicester' => 'BBC Leicester',
'bbc_radio_derby' => 'BBC Derby',
'bbc_radio_stoke' => 'BBC Stoke',
'bbc_radio_shropshire' => 'BBC Shropshire',
'bbc_wm' => 'BBC WM',
'bbc_radio_coventry_warwickshire' => 'BBC Coventry & Warwickshire',
'bbc_radio_hereford_worcester' => 'BBC Hereford & Worcester',
'bbc_radio_northampton' => 'BBC Northampton',
'bbc_three_counties_radio' => 'BBC Three Counties',
'bbc_radio_cambridge' => 'BBC Cambridgeshire',
'bbc_radio_norfolk' => 'BBC Norfolk',
'bbc_radio_suffolk' => 'BBC Suffolk',
'bbc_radio_sussex' => 'BBC Sussex',
'bbc_radio_essex' => 'BBC Essex',
'bbc_london' => 'BBC London',
'bbc_radio_kent' => 'BBC Kent',
'bbc_southern_counties_radio' => 'BBC Southern Counties',
'bbc_radio_oxford' => 'BBC Oxford',
'bbc_radio_berkshire' => 'BBC Berkshire',
'bbc_radio_solent' => 'BBC Solent',
'bbc_radio_gloucestershire' => 'BBC Gloucestershire',
'bbc_radio_swindon' => 'BBC Swindon',
'bbc_radio_wiltshire' => 'BBC Wiltshire',
'bbc_radio_bristol' => 'BBC Bristol',
'bbc_radio_somerset_sound' => 'BBC Somerset',
'bbc_radio_devon' => 'BBC Devon',
'bbc_radio_cornwall' => 'BBC Cornwall',
'bbc_radio_guernsey' => 'BBC Guernsey',
'bbc_radio_jersey' => 'BBC Jersey',
};
}
# Class cmdline Options
sub opt_format {
return {
liveradiomode => [ 1, "liveradiomode=s", 'Recording', '--liveradiomode ,,..', "Live Radio Recording modes: flashaac,realaudio,wma"],
outputliveradio => [ 1, "outputliveradio=s", 'Output', '--outputliveradio ', "Output directory for live radio recordings"],
rtmpliveradioopts => [ 1, "rtmp-liveradio-opts|rtmpliveradioopts=s", 'Recording', '--rtmp-liveradio-opts ', "Add custom options to flvstreamer for liveradio"],
};
}
# This gets run before the download retry loop if this class type is selected
sub init {
# Force certain options for Live
# Force --raw otherwise realaudio stdout streaming fails
# (this would normally be a bad thing but since its a live stream we
# won't be downloading other types of progs afterwards)
$opt->{raw} = 1 if $opt->{stdout} && $opt->{nowrite};
# Force only one try if live and recording to file
$opt->{attempts} = 1 if ( ! $opt->{attempts} ) && ( ! $opt->{nowrite} );
# Force to skip checking history if live
$opt->{force} = 1;
}
# Returns the modes to try for this prog type
sub modelist {
my $prog = shift;
my $mlist = $opt->{liveradiomode} || $opt->{modes};
# Defaults
if ( ! $mlist ) {
if ( ! main::exists_in_path('flvstreamer') ) {
main::logger "WARNING: Not using flash modes since flvstreamer is not found\n" if $opt->{verbose};
$mlist = 'realaudio,wma';
} else {
$mlist = 'flashaachigh,flashaacstd,realaudio,flashaaclow,wma';
}
}
# Deal with BBC Radio fallback modes and expansions
# Valid modes are rtmp,flashaac,realaudio,wmv
# 'rtmp' or 'flash' => 'flashaac'
# flashaac => flashaachigh,flashaacstd,flashaaclow
# flashaachigh => flashaachigh1,flashaachigh2
$mlist = main::expand_list($mlist, 'best', 'flashaachigh,flashaacstd,realaudio,flashaaclow,wma');
$mlist = main::expand_list($mlist, 'flash', 'flashaac');
$mlist = main::expand_list($mlist, 'rtmp', 'flashaac');
$mlist = main::expand_list($mlist, 'flashaac', 'flashaachigh,flashaacstd,flashaaclow');
return $mlist;
}
# Default minimum expected download size for a programme type
sub min_download_size {
return 102400;
}
################### Streamer class #################
package Streamer;
# Class vars
# Global options
my $optref;
my $opt;
# Constructor
# Usage: $streamer = Streamer->new();
sub new {
my $type = shift;
my %params = @_;
my $self = {};
for (keys %params) {
$self->{$_} = $params{$_};
}
# Ensure the subclass $opt var is pointing to the Superclass global optref
$opt = $Streamer::optref;
bless $self, $type;
}
# Use to bind a new options ref to the class global $optref var
sub add_opt_object {
my $self = shift;
$Streamer::optref = shift;
}
# $opt->{
} access method
sub opt {
my $self = shift;
my $optname = shift;
return $opt->{$optname};
}
################### Streamer::iphone class #################
package Streamer::iphone;
# Inherit from Streamer class
use base 'Streamer';
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# Generic
# Get streaming iphone URL
# More iphone stream data http://www.bbc.co.uk/json/stream/b0067vmx/iplayer_streaming_http_mp4?r=585330738351 HTTP/1.1
# Capabilities based on IP address: http://www.bbc.co.uk/mobile/iplayer-mgw/damp/proxytodemi?ip=111.222.333.444
# Category codes list: http://www.bbc.co.uk/mobile/iwiplayer/category_codes.php
sub get_url {
shift;
my $ua = shift;
my $pid = shift;
# Look for href="http://download.iplayer.bbc.co.uk/iplayer_streaming_http_mp4/5439950172312621205.mp4?token=iVX.lots.of.text.x9Z%2F2GNBdQKl0%3D%0A&pid=b00qhs36"
my $url;
my $iphone_download_prefix = 'http://www.bbc.co.uk/mobile/iplayer/episode';
my $url_0 = ${iphone_download_prefix}.'/'.${pid};
main::logger "INFO: iphone stream URL = $url_0\n" if $opt->{verbose};
my $safari_ua = main::create_ua( 'safari' );
my $html = main::request_url_retry( $safari_ua, $url_0, 3, undef, undef, 1 );
$html =~ s/\n/ /g;
# Check for guidance warning
my $guidance_post;
$guidance_post = $1 if $html =~ m{(isOver\d+)};
if ( $guidance_post ) {
my $h = new HTTP::Headers(
'User-Agent' => main::user_agent( 'coremedia' ),
'Accept' => '*/*',
'Accept-Language' => 'en',
'Connection' => 'keep-alive',
'Pragma' => 'no-cache',
);
main::logger "INFO: Guidance '$guidance_post' Warning Detected\n" if $opt->{verbose};
# Now post this var and get html again
my $req = HTTP::Request->new('POST', $url_0, $h);
$req->content_type('application/x-www-form-urlencoded');
$req->content('form=guidanceprompt&'.$guidance_post.'=1');
my $res = $ua->request($req);
$html = $res->as_string;
}
$url = decode_entities($1) if $html =~ m{href="(http.//download\.iplayer\.bbc\.co\.uk/iplayer_streaming_http_mp4.+?)"};
main::logger "DEBUG: Got iphone mediaselector URL: $url\n" if $opt->{verbose};
if ( ! $url ) {
main::logger "ERROR: Failed to get iphone URL from iplayer site\n\n";
}
return $url;
}
# %prog (only for %prog for mode and tagging)
# Get the h.264/mp3 stream
# ( $stream, $ua, $url_2, $prog )
sub get {
my ( $stream, $ua, $url_2, $prog ) = @_;
my $childpid;
my $iphone_block_size = 0x2000000; # 32MB
# Stage 3a: Download 1st byte to get exact file length
main::logger "INFO: Stage 3 URL = $url_2\n" if $opt->{verbose};
# Use url prepend if required
if ( defined $opt->{proxy} && $opt->{proxy} =~ /^prepend:/ ) {
$url_2 = $opt->{proxy}.main::url_encode( $url_2 );
$url_2 =~ s/^prepend://g;
}
# Setup request header
my $h = new HTTP::Headers(
'User-Agent' => main::user_agent( 'coremedia' ),
'Accept' => '*/*',
'Range' => 'bytes=0-1',
);
# detect bad url => not available
if ( $url_2 !~ /^http:\/\// ) {
main::logger "WARNING: iphone version not available\n";
return 'next';
}
my $req = HTTP::Request->new ('GET', $url_2, $h);
my $res = $ua->request($req);
# e.g. Content-Range: bytes 0-1/181338136 (return if no content length returned)
my $download_len = $res->header("Content-Range");
if ( ! $download_len ) {
main::logger "WARNING: iphone version not available\n";
return 'retry';
}
$download_len =~ s|^bytes 0-1/(\d+).*$|$1|;
main::logger "INFO: Download File Length $download_len\n" if $opt->{verbose};
# Only do this if we're rearranging QT streams
my $mdat_start = 0;
# default (tells the download chunk loop where to stop - i.e. EOF instead of end of mdat atom)
my $moov_start = $download_len + 1;
my $header;
# If we have partial content and wish to stream, resume the recording & spawn off STDOUT from existing file start
# Sanity check - we cannot support resuming of partial content if we're streaming also.
if ( $opt->{stdout} && (! $opt->{nowrite}) && -f $prog->{filepart} ) {
main::logger "WARNING: Partially recorded file exists, streaming will start from the beginning of the programme\n";
# Don't do usual streaming code - also force all messages to go to stderr
delete $opt->{stdout};
$opt->{stderr} = 1;
$childpid = fork();
if (! $childpid) {
# Child starts here
main::logger "INFO: Streaming directly for partially recorded file $prog->{filepart}\n";
if ( ! open( STREAMIN, "< $prog->{filepart}" ) ) {
main::logger "INFO: Cannot Read partially recorded file to stream\n";
exit 4;
}
my $outbuf;
# Write out until we run out of bytes
my $bytes_read = 65536;
while ( $bytes_read == 65536 ) {
$bytes_read = read(STREAMIN, $outbuf, 65536 );
#main::logger "INFO: Read $bytes_read bytes\n";
print STDOUT $outbuf;
}
close STREAMIN;
main::logger "INFO: Stream thread has completed\n";
exit 0;
}
}
# Open file if required
my $fh = main::open_file_append($prog->{filepart});
# If the partial file already exists, then resume from the correct mdat/download offset
my $restart_offset = 0;
my $moovdata;
my $moov_length = 0;
# If we have a too-small-sized file (greater than moov_length+mdat_start) and not stdout and not no-write then this is a partial recording
if (-f $prog->{filepart} && (! $opt->{stdout}) && (! $opt->{nowrite}) && stat($prog->{filepart})->size > ($moov_length+$mdat_start) ) {
# Calculate new start offset (considering that we've put moov first in file)
$restart_offset = stat($prog->{filepart})->size - $moov_length;
main::logger "INFO: Resuming recording from $restart_offset \n";
}
# Not sure if this is already done in download method???
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filepart} ) if $opt->{symlink};
# Start marker
my $start_time = time();
# Download mdat in blocks
my $chunk_size = $iphone_block_size;
for ( my $s = $restart_offset; $s < ${moov_start}-1; $s+= $chunk_size ) {
# get mdat chunk into file
my $retcode;
my $e;
# Get block end offset
if ( ($s + $chunk_size - 1) > (${moov_start}-1) ) {
$e = $moov_start - 1;
} else {
$e = $s + $chunk_size - 1;
}
# Get block from URL and append to $prog->{filepart}
if ( main::download_block($prog->{filepart}, $url_2, $ua, $s, $e, $download_len, $fh ) ) {
main::logger "\rERROR: Could not download block $s - $e from $prog->{filepart}\n\n";
return 'retry';
}
}
# Close fh
close $fh;
# end marker
my $end_time = time() + 0.0001;
# Calculate average speed, duration and total bytes recorded
main::logger sprintf("\rINFO: Recorded %.2fMB in %s at %5.0fkbps to %s\n",
($moov_start - 1 - $restart_offset) / (1024.0 * 1024.0),
sprintf("%02d:%02d:%02d", ( gmtime($end_time - $start_time))[2,1,0] ),
( $moov_start - 1 - $restart_offset ) / ($end_time - $start_time) / 1024.0 * 8.0,
$prog->{filename} );
# Moving file into place as complete (if not stdout)
move($prog->{filepart}, $prog->{filename}) if $prog->{filepart} ne $prog->{filename} && ! $opt->{stdout};
# Re-symlink file
$prog->create_symlink( $prog->{symlink}, $prog->{filename} ) if $opt->{symlink};
return 0;
}
################### Streamer::rtmp class #################
package Streamer::rtmp;
# Inherit from Streamer class
use base 'Streamer';
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::Spec;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
sub opt_format {
return {
ffmpeg => [ 0, "ffmpeg=s", 'External Program', '--ffmpeg ', "Location of ffmpeg binary"],
rtmpport => [ 1, "rtmpport=n", 'Recording', '--rtmpport ', "Override the RTMP port (e.g. 443)"],
flvstreamer => [ 0, "flvstreamer=s", 'External Program', '--flvstreamer ', "Location of flvstreamer binary"],
};
}
# %prog (only for {ext} and {mode})
# Actually do the RTMP streaming
sub get {
my ( $stream, undef, undef, $prog, %streamdata ) = @_;
my @cmdopts;
my $url_2 = $streamdata{streamurl};
my $server = $streamdata{server};
my $application = $streamdata{application};
my $tcurl = $streamdata{tcurl};
my $authstring = $streamdata{authstring};
my $swfurl = $streamdata{swfurl};
my $playpath = $streamdata{playpath};
my $port = $streamdata{port} || $opt->{rtmpport} || 1935;
my $protocol = $streamdata{protocol} || 0;
my $pageurl = $prog->{player};
my $mode = $prog->{mode};
push @cmdopts, ( split /\s+/, $streamdata{extraopts} ) if $streamdata{extraopts};
my $file_tmp;
my @cmd;
my $swfarg = "--swfUrl";
if ( $opt->{raw} ) {
$file_tmp = $prog->{filepart};
} else {
$file_tmp = $prog->{filepart}.'.flv'
}
# Remove failed file recording (below a certain size) - hack to get around flvstreamer not returning correct exit code
if ( -f $file_tmp && stat($file_tmp)->size < $prog->min_download_size() ) {
unlink( $file_tmp );
}
# Add custom options to flvstreamer for this type if specified with --rtmp--opts
if ( defined $opt->{'rtmp'.$prog->{type}.'opts'} ) {
push @cmdopts, ( split /\s+/, $opt->{'rtmp'.$prog->{type}.'opts'} );
}
# flvstreamer version detection e.g. 'FLVStreamer v1.8a'
my $rtmpver = `"$bin->{flvstreamer}" --help 2>&1`;
if ( $rtmpver =~ /swfVfy/ ) {
$swfarg = "--swfVfy";
} else {
main::logger "WARNING: Your version of flvstreamer/rtmpdump does not support SWF Verification\n";
}
$rtmpver =~ s/^\w+\s+v?([\.\d]+)(.*\n)*$/$1/g;
main::logger "INFO: $bin->{flvstreamer} version $rtmpver\n" if $opt->{verbose};
main::logger "INFO: RTMP_URL: $url_2, tcUrl: $tcurl, application: $application, authString: $authstring, swfUrl: $swfurl, file: $prog->{filepart}, file_done: $prog->{filename}\n" if $opt->{verbose};
# Save the effort and don't support < v1.8
if ( $rtmpver < 1.8 ) {
main::logger "WARNING: rtmpdump/flvstreamer 1.8 or later is required - please upgrade\n";
return 'next';
}
# Add --live option if required
push @cmdopts, '--live' if $streamdata{live};
# Add start stop options if defined
if ( $opt->{start} || $opt->{stop} ) {
push @cmdopts, ( '--start', $opt->{start} ) if $opt->{start};
push @cmdopts, ( '--stop', $opt->{stop} ) if $opt->{stop};
}
# Add hashes option if required
push @cmdopts, '--hashes' if $opt->{hash};
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $file_tmp ) if $opt->{symlink};
# Deal with stdout streaming
if ( $opt->{stdout} && not $opt->{nowrite} ) {
main::logger "ERROR: Cannot stream RTMP to STDOUT and file simultaneously\n";
exit 4;
}
push @cmdopts, ( '--resume', '-o', $file_tmp ) if ! ( $opt->{stdout} && $opt->{nowrite} );
push @cmdopts, @{ $binopts->{flvstreamer} } if $binopts->{flvstreamer};
my $return;
# Different invocation depending on version
# if playpath is defined
if ( $playpath ) {
@cmd = (
$bin->{flvstreamer},
'--port', $port,
'--protocol', $protocol,
'--playpath', $playpath,
'--host', $server,
$swfarg, $swfurl,
'--tcUrl', $tcurl,
'--app', $application,
'--pageUrl', $pageurl,
@cmdopts,
);
# Using just streamurl (i.e. no playpath defined)
} else {
@cmd = (
$bin->{flvstreamer},
'--port', $port,
'--protocol', $protocol,
'--rtmp', $streamdata{streamurl},
@cmdopts,
);
}
$return = main::run_cmd( 'normal', @cmd );
# exit behaviour when streaming
if ( $opt->{nowrite} && $opt->{stdout} ) {
if ( $return == 0 ) {
main::logger "\nINFO: Streaming completed successfully\n";
return 0;
} else {
main::logger "\nINFO: Streaming failed with exit code $return\n";
return 'abort';
}
}
# if we fail during the rtmp streaming, try to resume (this gets new streamdata again so that it isn't stale)
return 'retry' if $return && -f $file_tmp && stat($file_tmp)->size > $prog->min_download_size();
# If file is too small or non-existent then delete and try next mode
if ( (! -f $file_tmp) || ( -f $file_tmp && stat($file_tmp)->size < $prog->min_download_size()) ) {
main::logger "WARNING: Failed to stream file $file_tmp via RTMP\n";
unlink $file_tmp;
return 'next';
}
# Retain raw flv format if required
if ( $opt->{raw} ) {
move($file_tmp, $prog->{filename}) if $file_tmp ne $prog->{filename} && ! $opt->{stdout};
return 0;
# Convert flv to mp3/aac
} elsif ( $mode =~ /^flashaudio/ ) {
# We could do id3 tagging here with ffmpeg but id3v2 does this later anyway
# This fails
# $cmd = "$bin->{ffmpeg} -i \"$file_tmp\" -vn -acodec copy -y \"$prog->{filepart}\" 1>&2";
# This works but it's really bad bacause it re-transcodes mp3 and takes forever :-(
# $cmd = "$bin->{ffmpeg} -i \"$file_tmp\" -acodec libmp3lame -ac 2 -ab 128k -vn -y \"$prog->{filepart}\" 1>&2";
# At last this removes the flv container and dumps the mp3 stream! - mplayer dumps core but apparently succeeds
@cmd = (
$bin->{mplayer},
@{ $binopts->{mplayer} },
'-dumpaudio',
$file_tmp,
'-dumpfile', $prog->{filepart},
);
# Convert flv to aac/mp4a/mp3
} elsif ( $mode =~ /flashaac/ ) {
# transcode to MP3 if directed. If mp3vbr is not set then perform CBR.
if ( $opt->{aactomp3} ) {
my @br_opts = ('-ab', '128k');
if ( $opt->{mp3vbr} =~ /^\d$/ ) {
@br_opts = ('-aq', $opt->{mp3vbr});
}
@cmd = (
$bin->{ffmpeg},
'-i', $file_tmp,
'-vn',
'-acodec', 'libmp3lame', '-ac', '2', @br_opts,
'-y', $prog->{filepart},
);
} else {
@cmd = (
$bin->{ffmpeg},
'-i', $file_tmp,
'-vn',
'-acodec', 'copy',
'-y', $prog->{filepart},
);
}
# Convert video flv to mkv if required
} elsif ( $opt->{mkv} ) {
@cmd = (
$bin->{ffmpeg},
'-i', $file_tmp,
'-vcodec', 'copy',
'-acodec', 'copy',
'-y', $prog->{filepart},
);
# Convert video flv to mp4/avi if required
} else {
@cmd = (
$bin->{ffmpeg},
'-i', $file_tmp,
'-vcodec', 'copy',
'-acodec', 'copy',
'-f', $prog->{ext},
'-y', $prog->{filepart},
);
}
# Run flv conversion and delete source file on success
my $return = main::run_cmd( 'STDERR', @cmd );
if ( (! $return) && -f $prog->{filepart} && stat($prog->{filepart})->size > $prog->min_download_size() ) {
unlink( $file_tmp );
# If we have an aac file use ffmpeg to pack in m4a container and remove adts headers
# Have to do a second ffmpeg call because remuxing flv to m4a with -absf aac_adtstoasc gives corrupt m4a
# flv -> aac -> m4a works
if ( $mode =~ /flashaac/ && $prog->{ext} eq 'aac' && ! $opt->{aactomp3} ) {
# Temp file is now partial file from flv->aac conversion
# Change the extension to m4a for later info / debug messages
# final and partial filenames use new extension
$file_tmp = $prog->{filepart};
$prog->{ext} = 'm4a';
$prog->{filename} = File::Spec->catfile($prog->{dir}, "$prog->{fileprefix}.$prog->{ext}");
$prog->{filepart} = File::Spec->catfile($prog->{dir}, "$prog->{fileprefix}.partial.$prog->{ext}");
@cmd = (
$bin->{ffmpeg},
'-i', $file_tmp,
'-vn',
'-acodec', 'copy',
'-absf', 'aac_adtstoasc',
'-y', $prog->{filepart},
);
# Run aac conversion and delete source file on success
my $return = main::run_cmd( 'STDERR', @cmd );
if ( (! $return) && -f $prog->{filepart} && stat($prog->{filepart})->size > $prog->min_download_size() ) {
unlink( $file_tmp );
# If the ffmpeg conversion failed, remove the failed-converted file attempt - move the file as done anyway
} else {
main::logger "WARNING: aac conversion failed - retaining aac file\n";
unlink $prog->{filepart};
$prog->{filepart} = $file_tmp;
$prog->{filename} = $file_tmp;
# reset the extension to aac for later info / debug messages
$prog->{ext} = 'aac';
}
}
# If the ffmpeg conversion failed, remove the failed-converted file attempt - move the file as done anyway
} else {
main::logger "WARNING: flv conversion failed - retaining flv file\n";
unlink $prog->{filepart};
$prog->{filepart} = $file_tmp;
$prog->{filename} = $file_tmp;
}
# Moving file into place as complete (if not stdout)
move($prog->{filepart}, $prog->{filename}) if $prog->{filepart} ne $prog->{filename} && ! $opt->{stdout};
# Re-symlink file
$prog->create_symlink( $prog->{symlink}, $prog->{filename} ) if $opt->{symlink};
main::logger "INFO: Recorded $prog->{filename}\n";
return 0;
}
package Streamer::rtsp;
# Inherit from Streamer class
use base 'Streamer';
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# %prog (only for lame id3 tagging and {mode})
# Actually do the rtsp streaming
sub get {
my ( $stream, $ua, $url, $prog ) = @_;
my $childpid;
# get bandwidth options value
# Download bandwidth bps used for rtsp streams
my $bandwidth = $opt->{bandwidth} || 512000;
# Parse/recurse playlist if required to get mms url
$url = main::get_playlist_url( $ua, $url, 'rtsp' );
# Add stop and start if defined
# append: ?start=5400&end=7400 or &start=5400&end=7400
if ( $opt->{start} || $opt->{stop} ) {
# Make sure we add the correct separator for adding to the rtsp url
my $prefix_char = '?';
$prefix_char = '&' if $url =~ m/\?.+/;
if ( $opt->{start} && $opt->{stop} ) {
$url .= "${prefix_char}start=$opt->{start}&end=$opt->{stop}";
} elsif ( $opt->{start} && not $opt->{stop} ) {
$url .= "${prefix_char}start=$opt->{start}";
} elsif ( $opt->{stop} && not $opt->{start} ) {
$url .= "${prefix_char}end=$opt->{stop}";
}
}
# Create named pipe
if ( $^O !~ /^MSWin32$/ ) {
mkfifo($namedpipe, 0700);
} else {
main::logger "WARNING: fifos/named pipes are not supported - only limited output modes will be supported\n";
}
main::logger "INFO: RTSP URL = $url\n" if $opt->{verbose};
# Create ID3 tagging options for lame (escape " for shell)
my ( $id3_name, $id3_episode, $id3_desc, $id3_channel ) = ( $prog->{name}, $prog->{episode}, $prog->{desc}, $prog->{channel} );
s|"|\\"|g for ($id3_name, $id3_episode, $id3_desc, $id3_channel);
$binopts->{lame} .= " --ignore-tag-errors --ty ".( (localtime())[5] + 1900 )." --tl \"$id3_name\" --tt \"$id3_episode\" --ta \"$id3_channel\" --tc \"$id3_desc\" ";
# Use post-streaming transcoding using lame if namedpipes are not supported (i.e. ActivePerl/Windows)
# (Fallback if no namedpipe support and raw/wav not specified)
if ( ( ! -p $namedpipe ) && ! ( $opt->{raw} || $opt->{wav} ) ) {
my @cmd;
# Remove filename extension
$prog->{filepart} =~ s/\.mp3$//gi;
# Remove named pipe
unlink $namedpipe;
main::logger "INFO: Recording wav format (followed by transcoding)\n";
my $wavfile = "$prog->{filepart}.wav";
# Strip off any leading drivename in win32 - mplayer doesn't like this for pcm output files
$wavfile =~ s|^[a-zA-Z]:||g;
@cmd = (
$bin->{mplayer},
@{ $binopts->{mplayer} },
'-cache', 128,
'-bandwidth', $bandwidth,
'-vc', 'null',
'-vo', 'null',
'-ao', "pcm:waveheader:fast:file=\"$wavfile\"",
$url,
);
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, "$prog->{filepart}.wav" ) if $opt->{symlink};
if ( main::run_cmd( 'STDERR', @cmd ) ) {
unlink $prog->{symlink};
return 'next';
}
# Transcode
main::logger "INFO: Transcoding $prog->{filepart}.wav\n";
my $cmd = "$bin->{lame} $binopts->{lame} \"$prog->{filepart}.wav\" \"$prog->{filepart}.mp3\" 1>&2";
main::logger "DEGUG: Running $cmd\n" if $opt->{debug};
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, "$prog->{filepart}.mp3" ) if $opt->{symlink};
if ( system($cmd) || (-f "$prog->{filepart}.wav" && stat("$prog->{filepart}.wav")->size < $prog->min_download_size()) ) {
unlink $prog->{symlink};
return 'next';
}
unlink "$prog->{filepart}.wav";
move "$prog->{filepart}.mp3", $prog->{filename};
$prog->{ext} = 'mp3';
} elsif ( $opt->{wav} && ! $opt->{stdout} ) {
main::logger "INFO: Writing wav format\n";
my $wavfile = $prog->{filepart};
# Strip off any leading drivename in win32 - mplayer doesn't like this for pcm output files
$wavfile =~ s|^[a-zA-Z]:||g;
# Start the mplayer process and write to wav file
my @cmd = (
$bin->{mplayer},
@{ $binopts->{mplayer} },
'-cache', 128,
'-bandwidth', $bandwidth,
'-vc', 'null',
'-vo', 'null',
'-ao', "pcm:waveheader:fast:file=\"$wavfile\"",
$url,
);
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filepart} ) if $opt->{symlink};
if ( main::run_cmd( 'STDERR', @cmd ) ) {
unlink $prog->{symlink};
return 'next';
}
# Move file to done state
move $prog->{filepart}, $prog->{filename} if $prog->{filepart} ne $prog->{filename} && ! $opt->{nowrite};
# No transcoding if --raw was specified
} elsif ( $opt->{raw} && ! $opt->{stdout} ) {
# Write out to .ra ext instead (used on fallback if no fifo support)
main::logger "INFO: Writing raw realaudio stream\n";
# Start the mplayer process and write to raw file
my @cmd = (
$bin->{mplayer},
@{ $binopts->{mplayer} },
'-cache', 128,
'-bandwidth', $bandwidth,
'-dumpstream',
'-dumpfile', $prog->{filepart},
$url,
);
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filepart} ) if $opt->{symlink};
if ( main::run_cmd( 'STDERR', @cmd ) ) {
unlink $prog->{symlink};
return 'next';
}
# Move file to done state
move $prog->{filepart}, $prog->{filename} if $prog->{filepart} ne $prog->{filename} && ! $opt->{nowrite};
# Fork a child to do transcoding on the fly using a named pipe written to by mplayer
# Use transcoding via named pipes
} elsif ( -p $namedpipe ) {
$childpid = fork();
if (! $childpid) {
# Child starts here
$| = 1;
main::logger "INFO: Transcoding $prog->{filepart}\n";
# Stream mp3 to file and stdout simultaneously
if ( $opt->{stdout} && ! $opt->{nowrite} ) {
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filepart} ) if $opt->{symlink};
if ( $opt->{wav} || $opt->{raw} ) {
# Race condition - closes named pipe immediately unless we wait
sleep 5;
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filepart} ) if $opt->{symlink};
main::tee($namedpipe, $prog->{filepart});
#system( "cat $namedpipe 2>/dev/null| $bin->{tee} $prog->{filepart}");
} else {
my $cmd = "$bin->{lame} $binopts->{lame} \"$namedpipe\" - 2>/dev/null| $bin->{tee} \"$prog->{filepart}\"";
main::logger "DEGUG: Running $cmd\n" if $opt->{debug};
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filepart} ) if $opt->{symlink};
system($cmd);
}
# Stream mp3 stdout only
} elsif ( $opt->{stdout} && $opt->{nowrite} ) {
if ( $opt->{wav} || $opt->{raw} ) {
sleep 5;
main::tee($namedpipe);
#system( "cat $namedpipe 2>/dev/null");
} else {
my $cmd = "$bin->{lame} $binopts->{lame} \"$namedpipe\" - 2>/dev/null";
main::logger "DEGUG: Running $cmd\n" if $opt->{debug};
system( "$bin->{lame} $binopts->{lame} \"$namedpipe\" - 2>/dev/null");
}
# Stream mp3 to file directly
} elsif ( ! $opt->{stdout} ) {
my $cmd = "$bin->{lame} $binopts->{lame} \"$namedpipe\" \"$prog->{filepart}\" >/dev/null 2>/dev/null";
main::logger "DEGUG: Running $cmd\n" if $opt->{debug};
# Create symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filepart} ) if $opt->{symlink};
system($cmd);
}
# Remove named pipe
unlink $namedpipe;
# Move file to done state
move $prog->{filepart}, $prog->{filename} if $prog->{filepart} ne $prog->{filename} && ! $opt->{nowrite};
main::logger "INFO: Transcoding thread has completed\n";
# Re-symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filename} ) if $opt->{symlink};
exit 0;
}
# Start the mplayer process and write to named pipe
# Raw mode
if ( $opt->{raw} ) {
my @cmd = (
$bin->{mplayer},
@{ $binopts->{mplayer} },
'-cache', 32,
'-bandwidth', $bandwidth,
'-dumpstream',
'-dumpfile', $namedpipe,
$url,
);
if ( main::run_cmd( 'STDERR', @cmd ) ) {
# If we fail then kill off child processes
kill 9, $childpid;
unlink $prog->{symlink};
return 'next';
}
# WAV / mp3 mode - seems to fail....
} else {
my @cmd = (
$bin->{mplayer},
@{ $binopts->{mplayer} },
'-cache', 128,
'-bandwidth', $bandwidth,
'-vc', 'null',
'-vo', 'null',
'-ao', "pcm:waveheader:fast:file=$namedpipe",
$url,
);
if ( main::run_cmd( 'STDERR', @cmd ) ) {
# If we fail then kill off child processes
kill 9, $childpid;
unlink $prog->{symlink};
return 'next';
}
}
# Wait for child processes to prevent zombies
wait;
unlink $namedpipe;
} else {
main::logger "ERROR: Unsupported method of download on this platform\n";
return 'next';
}
main::logger "INFO: Recorded $prog->{filename}\n";
# Re-symlink if required
$prog->create_symlink( $prog->{symlink}, $prog->{filename} ) if $opt->{symlink};
return 0;
}
package Streamer::mms;
# Inherit from Streamer class
use base 'Streamer';
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# %prog (only used for {mode} and generating multi-part file prefixes)
# Actually do the MMS video streaming
sub get {
my ( $stream, $ua, $urls, $prog ) = @_;
my $file_tmp;
my $cmd;
my @url_list = split /\|/, $urls;
my @file_tmp_list;
my %threadpid;
my $retries = $opt->{attempts} || 3;
main::logger "INFO: MMS_URLs: ".(join ', ', @url_list).", file: $prog->{filepart}, file_done: $prog->{filename}\n" if $opt->{verbose};
if ( $opt->{stdout} ) {
main::logger "ERROR: stdout streaming isn't supported for mms streams\n";
return 'next';
}
# Start marker
my $start_time = time();
# Download each mms url (multi-threaded to stream in parallel)
my $file_part_prefix = "$prog->{dir}/$prog->{fileprefix}_part";
for ( my $count = 0; $count <= $#url_list; $count++ ) {
# Parse/recurse playlist if required to get mms url
$url_list[$count] = main::get_playlist_url( $ua, $url_list[$count], 'mms' );
# Create temp recording filename
$file_tmp = sprintf( "%s%02d.".$prog->{ext}, $file_part_prefix, $count+1);
$file_tmp_list[$count] = $file_tmp;
#my $null;
#$null = '-really-quiet' if ! $opt->{quiet};
# Can also use 'mencoder mms://url/ -oac copy -ovc copy -o out.asf' - still gives zero exit code on failed stream...
# Can also use $bin->{vlc} --sout file/asf:\"$file_tmp\" \"$url_list[$count]\" vlc://quit
# The vlc cmd does not quit of there is an error - it just hangs
# $cmd = "$bin->{mplayer} $binopts->{mplayer} -dumpstream \"$url_list[$count]\" -dumpfile \"$file_tmp\" $null 1>&2";
# Use backticks to invoke mplayer and grab all output then grep for 'read error'
# problem is that the following output is given by mplayer at the end of liong streams:
#read error:: Operation now in progress
#pre-header read failed
#Core dumped ;)
#vo: x11 uninit called but X11 not initialized..
#
#Exiting... (End of file)
$cmd = "\"$bin->{mplayer}\" ".(join ' ', @{ $binopts->{mplayer} } )." -dumpstream \"$url_list[$count]\" -dumpfile \"$file_tmp\" 2>&1";
main::logger "INFO: Command: $cmd\n" if $opt->{verbose};
# fork streaming threads
if ( not $opt->{mmsnothread} ) {
my $childpid = fork();
if (! $childpid) {
# Child starts here
main::logger "INFO: Streaming to file $file_tmp\n";
# Remove old file
unlink $file_tmp;
# Retry loop
my $retry = $retries;
while ($retry) {
my $cmdoutput = `$cmd`;
my $exitcode = $?;
main::logger "DEBUG: Command '$cmd', Output:\n$cmdoutput\n\n" if $opt->{debug};
# Assume file is fully downloaded if > 10MB and we get an error reported !!!
if ( ( -f $prog->{filename} && stat($prog->{filename})->size < $prog->min_download_size()*10.0 && grep /(read error|connect error|Failed, exiting)/i, $cmdoutput ) || $exitcode ) {
# Failed, retry
main::logger "WARNING: Failed, retrying to stream $file_tmp, exit code: $exitcode\n";
$retry--;
} else {
# Successfully streamed
main::logger "INFO: Streaming thread has completed for file $file_tmp\n";
exit 0;
}
}
main::logger "ERROR: Record thread failed after $retries retries for $file_tmp (renamed to ${file_tmp}.failed)\n";
move $file_tmp, "${file_tmp}.failed";
exit 1;
}
# Create a hash of process_id => 'count'
$threadpid{$childpid} = $count;
# else stream each part in turn
} else {
# Child starts here
main::logger "INFO: Recording file $file_tmp\n";
# Remove old file
unlink $file_tmp;
# Retry loop
my $retry = $retries;
my $done = 0;
while ( $retry && not $done ) {
my $cmdoutput = `$cmd`;
my $exitcode = $?;
main::logger "DEBUG: Command '$cmd', Output:\n$cmdoutput\n\n" if $opt->{debug};
# Assume file is fully downloaded if > 10MB and we get an error reported !!!
if ( ( -f $prog->{filename} && stat($prog->{filename})->size < $prog->min_download_size()*10.0 && grep /(read error|connect error|Failed, exiting)/i, $cmdoutput ) || $exitcode ) {
#if ( grep /(read error|connect error|Failed, exiting)/i, $cmdoutput || $exitcode ) {
# Failed, retry
main::logger "DEBUG: Trace of failed command:\n####################\n${cmdoutput}\n####################\n" if $opt->{debug};
main::logger "WARNING: Failed, retrying to stream $file_tmp, exit code: $exitcode\n";
$retry--;
} else {
# Successfully downloaded
main::logger "INFO: Streaming has completed to file $file_tmp\n";
$done = 1;
}
}
# if the programme part failed after a few retries...
if (not $done) {
main::logger "ERROR: Recording failed after $retries retries for $file_tmp (renamed to ${file_tmp}.failed)\n";
move $file_tmp, "${file_tmp}.failed";
return 'next';
}
}
}
# If doing a threaded streaming, monitor the progress and thread completion
if ( not $opt->{mmsnothread} ) {
# Wait for all threads to complete
$| = 1;
# Autoreap zombies
$SIG{CHLD}='IGNORE';
my $done = 0;
my $done_symlink;
while (keys %threadpid) {
my @sizes;
my $total_size = 0;
my $total_size_new = 0;
my $format = "Threads: ";
sleep 1;
#main::logger "DEBUG: ProcessIDs: ".(join ',', keys %threadpid)."\n";
for my $procid (sort keys %threadpid) {
my $size = 0;
# Is this child still alive?
if ( kill 0 => $procid ) {
main::logger "DEBUG Thread $threadpid{$procid} still alive ($file_tmp_list[$threadpid{$procid}])\n" if $opt->{debug};
# Build the status string
$format .= "%d) %.3fMB ";
$size = stat($file_tmp_list[$threadpid{$procid}])->size if -f $file_tmp_list[$threadpid{$procid}];
push @sizes, $threadpid{$procid}+1, $size/(1024.0*1024.0);
$total_size_new += $size;
# Now create a symlink if this is the first part and size > $prog->min_download_size()
if ( $threadpid{$procid} == 0 && $done_symlink != 1 && $opt->{symlink} && $size > $prog->min_download_size() ) {
# Symlink to file if only one part or to dir if multi-part
if ( $#url_list ) {
$prog->create_symlink( $prog->{symlink}, $prog->{dir} );
} else {
$prog->create_symlink( $prog->{symlink}, $file_tmp_list[$threadpid{$procid}] );
}
$done_symlink = 1;
}
# Thread has completed/failed
} else {
$size = stat($file_tmp_list[$threadpid{$procid}])->size if -f $file_tmp_list[$threadpid{$procid}];
# end marker
my $end_time = time() + 0.0001;
# Calculate average speed, duration and total bytes downloaded
main::logger sprintf("INFO: Thread #%d Recorded %.2fMB in %s at %5.0fkbps to %s\n",
($threadpid{$procid}+1),
$size / (1024.0 * 1024.0),
sprintf("%02d:%02d:%02d", ( gmtime($end_time - $start_time))[2,1,0] ),
$size / ($end_time - $start_time) / 1024.0 * 8.0,
$file_tmp_list[$threadpid{$procid}] );
# Remove from thread test list
delete $threadpid{$procid};
}
}
$format .= " recorded (%.0fkbps) \r";
main::logger sprintf $format, @sizes, ($total_size_new - $total_size) / (time() - $start_time) / 1024.0 * 8.0;
}
main::logger "INFO: All streaming threads completed\n";
# Unset autoreap
delete $SIG{CHLD};
}
# If not all files > min_size then assume streaming failed
for (@file_tmp_list) {
# If file doesnt exist or too small then skip
if ( (! -f $_) || ( -f $_ && stat($_)->size < $prog->min_download_size() ) ) {
main::logger "ERROR: Recording of programme failed, skipping\n" if $opt->{verbose};
return 'next';
}
}
# # Retain raw format if required
# if ( $opt->{raw} ) {
# # Create symlink to first part file
# $prog->create_symlink( $prog->{symlink}, $file_tmp_list[0] ) if $opt->{symlink};
# return 0;
# }
#
# # Convert video asf to mp4 if required - need to find a suitable converter...
# } else {
# # Create part of cmd that specifies each partial file
# my $filestring;
# $filestring .= " -i \"$_\" " for (@file_tmp_list);
# $cmd = "$bin->{ffmpeg} $binopts->{ffmpeg} $filestring -vcodec copy -acodec copy -f $prog->{ext} -y \"$prog->{filepart}\" 1>&2";
# }
#
# main::logger "INFO: Command: $cmd\n\n" if $opt->{verbose};
# # Run asf conversion and delete source file on success
# if ( ! system($cmd) ) {
# unlink( @file_tmp_list );
# } else {
# main::logger "ERROR: asf conversion failed - retaining files ".(join ', ', @file_tmp_list)."\n";
# return 2;
# }
# # Moving file into place as complete (if not stdout)
# move($prog->{filepart}, $prog->{filename}) if ! $opt->{stdout};
# # Create symlink if required
# $prog->create_symlink( $prog->{symlink}, $prog->{filename} ) if $opt->{symlink};
return 0;
}
package Streamer::3gp;
# Inherit from Streamer class
use base 'Streamer';
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# Generic
# Actually do the 3gp / N95 h.264 streaming
sub get {
my ( $stream, $ua, $url, $prog ) = @_;
# Resolve URL if required
if ( $url =~ /^http/ ) {
my $url1 = main::request_url_retry($ua, $url, 2, '', '');
chomp($url1);
$url = $url1;
}
my @opts;
@opts = @{ $binopts->{vlc} } if $binopts->{vlc};
main::logger "INFO: URL = $url\n" if $opt->{verbose};
if ( ! $opt->{stdout} ) {
main::logger "INFO: Recording Low Quality H.264 stream\n";
my @cmd = (
$bin->{vlc},
@opts,
'--sout', 'file/ts:'.$prog->{filepart},
$url,
'vlc://quit',
);
if ( main::run_cmd( 'STDERR', @cmd ) ) {
return 'next';
}
# to STDOUT
} else {
main::logger "INFO: Streaming Low Quality H.264 stream to stdout\n";
my @cmd = (
$bin->{vlc},
@opts,
'--sout', 'file/ts:-',
$url,
'vlc://quit',
);
if ( main::run_cmd( 'STDERR', @cmd ) ) {
return 'next';
}
}
main::logger "INFO: Recorded $prog->{filename}\n";
# Moving file into place as complete (if not stdout)
move($prog->{filepart}, $prog->{filename}) if $prog->{filepart} ne $prog->{filename} && ! $opt->{stdout};
$prog->create_symlink( $prog->{symlink}, $prog->{filename} ) if $opt->{symlink};
return 0;
}
package Streamer::http;
# Inherit from Streamer class
use base 'Streamer';
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Headers;
use IO::Seekable;
use IO::Socket;
use LWP::ConnCache;
use LWP::UserAgent;
use POSIX qw(mkfifo);
use strict;
use Time::Local;
use URI;
# Generic
# Actually do the http streaming
sub get {
my ( $stream, $ua, $url, $prog ) = @_;
my $start_time = time();
# Set user agent
$ua->agent('get_iplayer');
main::logger "INFO: URL = $url\n" if $opt->{verbose};
# Resume partial recording?
my $start = 0;
if ( -f $prog->{filepart} ) {
$start = stat($prog->{filepart})->size;
main::logger "INFO: Resuming recording from $start\n";
}
my $fh = main::open_file_append($prog->{filepart});
if ( main::download_block($prog->{filepart}, $url, $ua, $start, undef, undef, $fh) != 0 ) {
main::logger "\rERROR: Recording failed\n";
close $fh;
return 'next';
} else {
close $fh;
# end marker
my $end_time = time() + 0.0001;
# Final file size
my $size = stat($prog->{filepart})->size;
# Calculate average speed, duration and total bytes downloaded
main::logger sprintf("\rINFO: Recorded %.2fMB in %s at %5.0fkbps to %s\n",
($size - $start) / (1024.0 * 1024.0),
sprintf("%02d:%02d:%02d", ( gmtime($end_time - $start_time))[2,1,0] ),
( $size - $start ) / ($end_time - $start_time) / 1024.0 * 8.0,
$prog->{filename} );
move $prog->{filepart}, $prog->{filename} if $prog->{filepart} ne $prog->{filename};
# re-symlink file
$prog->create_symlink( $prog->{symlink}, $prog->{filename} ) if $opt->{symlink};
}
return 0;
}
package Streamer::filestreamonly;
# Inherit from Streamer class
use base 'Streamer';
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use strict;
# Generic
# Actually do the file streaming
sub get {
my ( $stream, $ua, $url, $prog ) = @_;
my $start_time = time();
main::logger "INFO: URL = $url\n" if $opt->{verbose};
# Just remove any existing file
unlink $prog->{filepart};
# Streaming
if ( $opt->{stdout} && $opt->{nowrite} ) {
main::logger "INFO: Streaming $url to STDOUT\n" if $opt->{verbose};
if ( ! open(FH, "< $url") ) {
main::logger "ERROR: Cannot open $url: $!\n";
return 'next';
}
# Fix for binary - needed for Windows
binmode STDOUT;
# Read each char from command output and push to STDOUT
my $char;
my $bytes;
my $size = 200000;
while ( $bytes = read( FH, $char, $size ) ) {
if ( $bytes <= 0 ) {
close FH;
last;
} else {
print STDOUT $char;
}
last if $bytes < $size;
}
close FH;
main::logger "DEBUG: streaming $url completed\n" if $opt->{debug};
# Recording - disabled
} else {
main::logger "\rERROR: Recording failed - this is a stream-only programme\n";
return 'next';
}
return 0;
}
############# PVR Class ##############
package Pvr;
use Env qw[@PATH];
use Fcntl;
use File::Copy;
use File::Path;
use File::stat;
use IO::Seekable;
use IO::Socket;
use strict;
use Time::Local;
# Class vars
my %vars = {};
# Global options
my $optref;
my $opt_fileref;
my $opt_cmdlineref;
my $opt;
my $opt_file;
my $opt_cmdline;
# Class cmdline Options
sub opt_format {
return {
pvr => [ 0, "pvr|pvrrun|pvr-run!", 'PVR', '--pvr [pvr search name]', "Runs the PVR using all saved PVR searches (intended to be run every hour from cron etc). The list can be limited by adding a regex to the command. Synonyms: --pvrrun, --pvr-run"],
pvrexclude => [ 0, "pvrexclude|pvr-exclude=s", 'PVR', '--pvr-exclude ', "Exclude the PVR searches to run by search name (regex or comma separated values). Synonyms: --pvrexclude"],
pvrsingle => [ 0, "pvrsingle|pvr-single=s", 'PVR', '--pvr-single ', "Runs a named PVR search. Synonyms: --pvrsingle"],
pvradd => [ 0, "pvradd|pvr-add=s", 'PVR', '--pvr-add ', "Save the named PVR search with the specified search terms. Synonyms: --pvradd"],
pvrdel => [ 0, "pvrdel|pvr-del=s", 'PVR', '--pvr-del ', "Remove the named search from the PVR searches. Synonyms: --pvrdel"],
pvrdisable => [ 1, "pvrdisable|pvr-disable=s", 'PVR', '--pvr-disable ', "Disable (not delete) a named PVR search. Synonyms: --pvrdisable"],
pvrenable => [ 1, "pvrenable|pvr-enable=s", 'PVR', '--pvr-enable ', "Enable a previously disabled named PVR search. Synonyms: --pvrenable"],
pvrlist => [ 0, "pvrlist|pvr-list!", 'PVR', '--pvr-list', "Show the PVR search list. Synonyms: --pvrlist"],
pvrqueue => [ 0, "pvrqueue|pvr-queue!", 'PVR', '--pvr-queue', "Add currently matched programmes to queue for later one-off recording using the --pvr option. Synonyms: --pvrqueue"],
pvrscheduler => [ 0, "pvrscheduler|pvr-scheduler=n", 'PVR', '--pvr-scheduler ', "Runs the PVR using all saved PVR searches every . Synonyms: --pvrscheduler"],
comment => [ 1, "comment=s", 'PVR', '--comment ', "Adds a comment to a PVR search"],
};
}
# Constructor
# Usage: $pvr = Pvr->new();
sub new {
my $type = shift;
my %params = @_;
my $self = {};
for (keys %params) {
$self->{$_} = $params{$_};
}
## Ensure the subclass $opt var is pointing to the Superclass global optref
$opt = $Pvr::optref;
$opt_file = $Pvr::opt_fileref;
$opt_cmdline = $Pvr::opt_cmdlineref;
bless $self, $type;
}
# Use to bind a new options ref to the class global $opt_ref var
sub add_opt_object {
my $self = shift;
$Pvr::optref = shift;
}
# Use to bind a new options ref to the class global $opt_fileref var
sub add_opt_file_object {
my $self = shift;
$Pvr::opt_fileref = shift;
}
# Use to bind a new options ref to the class global $opt_cmdlineref var
sub add_opt_cmdline_object {
my $self = shift;
$Pvr::opt_cmdlineref = shift;
}
# Use to bind a new options ref to the class global $optref var
sub setvar {
my $self = shift;
my $varname = shift;
my $value = shift;
$vars{$varname} = $value;
}
sub getvar {
my $self = shift;
my $varname = shift;
return $vars{$varname};
}
# $opt->{
} access method
sub opt {
my $self = shift;
my $optname = shift;
return $opt->{$optname};
}
# Load all PVR searches and run one-by-one
# Usage: $pvr->run( [pvr search name] )
sub run {
my $pvr = shift;
my $pvr_name_regex = shift || '.*';
my $exclude_regex = '_ROUGE_VALUE_';
# Don't attempt to record programmes with pids in history
my $hist = History->new();
# Load all PVR searches
$pvr->load_list();
if ( $opt->{pvrexclude} ) {
$exclude_regex = '('.(join '|', ( split /,/, $opt->{pvrexclude} ) ).')';
}
# For each PVR search (or single one if specified)
my @names = ( grep !/$exclude_regex/i, grep /$pvr_name_regex/i, sort {lc $a cmp lc $b} keys %{$pvr} );
main::logger "Running PVR Searches:\n";
for my $name ( @names ) {
# Ignore if this search is disabled
if ( $pvr->{$name}->{disable} ) {
main::logger "\nSkipping '$name' (disabled)\n" if $opt->{verbose};
next;
}
main::logger "$name\n";
# Clear then Load options for specified pvr search name
my @search_args = $pvr->load_options($name);
## Display all options used for this pvr search
#$opt->display('Default Options', '(help|debug|get|^pvr)');
# Switch on --hide option
$opt->{hide} = 1;
# Switch off --future option (no point in checking future programmes)
$opt->{future} = '';
# Dont allow --refresh with --pvr
$opt->{refresh} = '';
# Do the recording (force --get option)
$opt->{get} = 1 if ! $opt->{test};
# If this is a one-off queue pid entry then delete the PVR entry upon successful recording(s)
if ( $pvr->{$name}->{pid} && $name =~ /^ONCE_/ ) {
my $failcount = main::find_pid_matches( $hist );
$pvr->del( $name ) if not $failcount;
# Just make recordings of matching progs
} else {
main::download_matches( $hist, main::find_matches( $hist, @search_args ) );
}
}
}
sub run_scheduler {
my $pvr = shift;
my $interval = $opt->{pvrscheduler};
# Ensure the caches refresh every run (assume cache refreshes take at most 300 seconds)
$opt_cmdline->{expiry} = $interval - 300;
main::logger "INFO: Scheduling the PVR to run every $interval secs\n";
while ( 1 ) {
my $start_time = time();
$opt_cmdline->{pvr} = 1;
$pvr->run();
my $remaining = $interval - ( time() - $start_time );
if ( $remaining > 0 ) {
main::logger "INFO: Sleeping for $remaining secs\n";
sleep $remaining;
}
}
}
# If queuing, only add pids because the index number might change by the time the pvr runs
# If --pid and --type is specified then add this prog also
sub queue {
my $pvr = shift;
my @search_args = @_;
# Switch on --hide option
$opt->{hide} = 1;
# Switch on --future option - we want to search upcoming programmes
$opt->{future} = 1;
my $hist = History->new();
# PID and TYPE specified
if ( $opt_cmdline->{pid} ) {
# ensure we only have one prog type defined
if ( $opt->{type} && $opt->{type} !~ /,/ ) {
# Add to PVR if not already in history (unless multimode specified)
$pvr->add( "ONCE_$opt_cmdline->{pid}" ) if ( ! $hist->check( $opt_cmdline->{pid} ) ) || $opt->{multimode};
} else {
main::logger "ERROR: Cannot add a pid to the PVR queue without a single --type specified\n";
return 1;
}
# Search specified
} else {
my @matches = main::find_matches( $hist, @search_args );
# Add a PVR entry for each matching prog PID
for my $this ( @matches ) {
$opt_cmdline->{pid} = $this->{pid};
$opt_cmdline->{type} = $this->{type};
$pvr->add( $this->substitute('ONCE_ - ') );
}
}
return 0;
}
# Save the options on the cmdline as a PVR search with the specified name
sub add {
my $pvr = shift;
my $name = shift;
my @search_args = @_;
my @options;
# validate name
if ( $name !~ m{[\w\-\+]+} ) {
main::logger "ERROR: Invalid PVR search name '$name'\n";
return 1;
}
# Parse valid options and create array (ignore options from the options files that have not been overriden on the cmdline)
for ( grep !/(webrequest|future|nocopyright|^test|metadataonly|subsonly|thumbonly|stdout|^get|refresh|^save|^prefs|help|expiry|nowrite|tree|terse|streaminfo|listformat|^list|showoptions|hide|info|pvr.*)$/, sort {lc $a cmp lc $b} keys %{$opt_cmdline} ) {
if ( defined $opt_cmdline->{$_} ) {
push @options, "$_ $opt_cmdline->{$_}";
main::logger "DEBUG: Adding option $_ = $opt_cmdline->{$_}\n" if $opt->{debug};
}
}
# Add search args to array
for ( my $count = 0; $count <= $#search_args; $count++ ) {
push @options, "search${count} $search_args[$count]";
main::logger "DEBUG: Adding search${count} = $search_args[$count]\n" if $opt->{debug};
}
# Save search to file
$pvr->save( $name, @options );
return 0;
}
# Delete the named PVR search
sub del {
my $pvr = shift;
my $name = shift;
# validate name
if ( $name !~ m{[\w\-\+]+} ) {
main::logger "ERROR: Invalid PVR search name '$name'\n";
return 1;
}
# Delete pvr search file
if ( -f $vars{pvr_dir}.$name ) {
unlink $vars{pvr_dir}.$name;
main::logger "INFO: Deleted PVR search '$name'\n";
} else {
main::logger "ERROR: PVR search '$name' does not exist\n";
return 1;
}
return 0;
}
# Display all the PVR searches
sub display_list {
my $pvr = shift;
# Load all the PVR searches
$pvr->load_list();
# Print out list
main::logger "All PVR Searches:\n\n";
for my $name ( sort {lc $a cmp lc $b} keys %{$pvr} ) {
# Report whether disabled
if ( $pvr->{$name}->{disable} ) {
main::logger "pvrsearch = $name (disabled)\n";
} else {
main::logger "pvrsearch = $name\n";
}
for ( sort keys %{ $pvr->{$name} } ) {
main::logger "\t$_ = $pvr->{$name}->{$_}\n";
}
main::logger "\n";
}
return 0;
}
# Load all the PVR searches into %{$pvr}
sub load_list {
my $pvr = shift;
# Clear any previous data in $pvr
$pvr->clear_list();
# Make dir if not existing
mkpath $vars{pvr_dir} if ! -d $vars{pvr_dir};
# Get list of files in pvr_dir
# open file with handle DIR
opendir( DIR, $vars{pvr_dir} );
if ( ! opendir( DIR, $vars{pvr_dir}) ) {
main::logger "ERROR: Cannot open directory $vars{pvr_dir}\n";
return 1;
}
# Get contents of directory (ignoring . .. and ~ files)
my @files = grep ! /(^\.{1,2}$|^.*~$)/, readdir DIR;
# Close the directory
closedir DIR;
# process each file
for my $file (@files) {
chomp($file);
# Re-add the dir
$file = "$vars{pvr_dir}/$file";
next if ! -f $file;
if ( ! open (PVR, "< $file") ) {
main::logger "WARNING: Cannot read PVR search file $file\n";
next;
}
my @options = ;
close PVR;
# Get search name from filename
my $name = $file;
$name =~ s/^.*\/([^\/]+?)$/$1/g;
for (@options) {
/^\s*([\w\-_]+?)\s+(.*)\s*$/;
main::logger "DEBUG: PVR search '$name': option $1 = $2\n" if $opt->{debug};
$pvr->{$name}->{$1} = $2;
}
main::logger "INFO: Loaded PVR search '$name'\n" if $opt->{verbose};
}
main::logger "INFO: Loaded PVR search list\n" if $opt->{verbose};
return 0;
}
# Clear all the PVR searches in %{$pvr}
sub clear_list {
my $pvr = shift;
# There is probably a faster way
delete $pvr->{$_} for keys %{ $pvr };
return 0;
}
# Save the array options specified as a PVR search
sub save {
my $pvr = shift;
my $name = shift;
my @options = @_;
# Sanitize name
$name = StringUtils::sanitize_path( $name );
# Make dir if not existing
mkpath $vars{pvr_dir} if ! -d $vars{pvr_dir};
main::logger "INFO: Saving PVR search '$name':\n";
# Open file
if ( ! open (PVR, "> $vars{pvr_dir}/${name}") ) {
main::logger "ERROR: Cannot save PVR search to $vars{pvr_dir}.$name\n";
return 1;
}
# Write options array to file
for (@options) {
print PVR "$_\n";
main::logger "\t$_\n";
}
close PVR;
return 0;
}
# Uses globals: $profile_dir, $optfile_system, $optfile_default
# Uses class globals: %opt, %opt_file, %opt_cmdline
# Returns @search_args
# Clear all exisiting global args and opts then load the options specified in the default options and specified PVR search
sub load_options {
my $pvr = shift;
my $name = shift;
my $optfile_preset;
# Clear out existing options and file options hashes
%{$opt} = ();
# If the preset option is used in the PVR search then use it.
if ( $pvr->{$name}->{preset} ) {
$optfile_preset = ${profile_dir}."/presets/".$pvr->{$name}->{preset};
main::logger "DEBUG: Using preset file: $optfile_preset\n" if $opt_cmdline->{debug};
}
# Re-copy options read from files at start of whole run
$opt->copy_set_options_from( $opt_file );
# Load options from $optfile_preset into $opt (uses $opt_cmdline as readonly options for debug/verbose etc)
$opt->load( $opt_cmdline, $optfile_preset );
# Clear search args
@search_args = ();
# Set each option from the search
for ( sort {$a cmp $b} keys %{ $pvr->{$name} } ) {
# Add to list of search args if this is not an option
if ( /^search\d+$/ ) {
main::logger "INFO: $_ = $pvr->{$name}->{$_}\n" if $opt->{verbose};
push @search_args, $pvr->{$name}->{$_};
# Else populate options, ignore disable option
} elsif ( $_ ne 'disable' ) {
main::logger "INFO: Option: $_ = $pvr->{$name}->{$_}\n" if $opt->{verbose};
$opt->{$_} = $pvr->{$name}->{$_};
}
}
# Allow cmdline args to override those in the PVR search
# Re-copy options from the cmdline
$opt->copy_set_options_from( $opt_cmdline );
return @search_args;
}
# Disable a PVR search by adding 'disable 1' option
sub disable {
my $pvr = shift;
my $name = shift;
$pvr->load_list();
my @options;
for ( keys %{ $pvr->{$name} }) {
push @options, "$_ $pvr->{$name}->{$_}";
}
# Add the disable option
push @options, 'disable 1';
$pvr->save( $name, @options );
return 0;
}
# Re-enable a PVR search by removing 'disable 1' option
sub enable {
my $pvr = shift;
my $name = shift;
$pvr->load_list();
my @options;
for ( keys %{ $pvr->{$name} }) {
push @options, "$_ $pvr->{$name}->{$_}";
}
# Remove the disable option
@options = grep !/^disable\s/, @options;
$pvr->save( $name, @options );
return 0;
}
package Tagger;
use Encode;
use File::stat;
# already in scope
# my ($opt, $bin);
# constructor
sub new {
my $class = shift;
my $self = {};
bless($self, $class);
}
# map metadata values to tags
sub tags_from_metadata {
my ($self, $meta) = @_;
my $tags;
# iTunes media kind
$tags->{stik} = 'Normal';
if ( $meta->{ext} =~ /(mp4|m4v)/i) {
$tags->{stik} = $meta->{categories} =~ /(film|movie)/i ? 'Movie' : 'TV Show';
}
$tags->{advisory} = $meta->{guidance} ? 'explicit' : 'remove';
# copyright message from download date
$tags->{copyright} = substr($meta->{dldate}, 0, 4)." British Broadcasting Corporation, all rights reserved";
# select version of of episode title to use
if ( $opt->{tag_fulltitle} ) {
$tags->{title} = $meta->{title};
} else {
# fix up episode if necessary
(my $title = $meta->{episode}) =~ s/[\s\-]+$//;
$tags->{title} = $title ? $title : $meta->{name};
}
$tags->{artist} = $meta->{channel};
# album artist from programme type
($tags->{albumArtist} = "BBC " . ucfirst($meta->{type})) =~ s/tv/TV/i;
$tags->{album} = $meta->{name};
$tags->{grouping} = $meta->{categories};
# composer references iPlayer
$tags->{composer} = "BBC iPlayer";
# extract genre as first category, use second if first too generic
my @ignore = ("Films", "Sign Zone", "Audio Described", "Northern Ireland", "Scotland", "Wales", "England");
my ($genre, $genre2) = split(/\s*,\s*/, $meta->{categories}, 3);
if ( $genre && $genre2 && grep(/$genre/i, @ignore) ) { $genre = $genre2; }
# fallback genre
$genre ||= "get_iplayer";
$tags->{genre} = $genre;
$tags->{comment} = $meta->{descshort};
# fix up firstbcast if necessary
$tags->{year} = $meta->{firstbcast};
if ( $tags->{year} !~ /\d{4}-\d{2}-\d{2}\D\d{2}:\d{2}:\d{2}/ ) {
my @utc = gmtime();
$utc[4] += 1;
$utc[5] += 1900;
$tags->{year} = sprintf("%4d-%02d-%02dT%02d:%02d:%02dZ", reverse @utc[0..5]);
}
# extract date components for ID3v2.3
my @date = split(//, $tags->{year});
$tags->{tyer} = join('', @date[0..3]);
$tags->{tdat} = join('', @date[8,9,5,6]);
$tags->{time} = join('', @date[11,12,14,15]);
$tags->{tracknum} = $meta->{episodenum};
$tags->{disk} = $meta->{seriesnum};
# generate lyrics text with links if available
$tags->{lyrics} = $meta->{desc};
$tags->{lyrics} .= "\n\nEPISODE\n $meta->{player}" if $meta->{player};
$tags->{lyrics} .= "\n\nSERIES\n $meta->{web}" if $meta->{web};
$tags->{description} = $meta->{descshort};
$tags->{longDescription} = $meta->{desc};
$tags->{hdvideo} = $meta->{mode} =~ /hd/i ? 'true' : 'false';
$tags->{TVShowName} = $meta->{name};
$tags->{TVEpisode} = $meta->{senum} ? $meta->{senum} : $meta->{pid};
$tags->{TVSeasonNum} = $tags->{disk};
$tags->{TVEpisodeNum} = $tags->{tracknum};
$tags->{TVNetwork} = $meta->{channel};
$tags->{podcastFlag} = 'true';
$tags->{category} = $tags->{genre};
$tags->{keyword} = $meta->{categories};
$tags->{podcastGUID} = $meta->{player};
$tags->{artwork} = $meta->{thumbfile};
# video flag
$tags->{is_video} = $meta->{ext} =~ /(mp4|m4v)/i;
# tvshow flag
$tags->{is_tvshow} = $tags->{stik} eq 'TV Show';
# podcast flag
$tags->{is_podcast} = $meta->{type} =~ /podcast/i || $opt->{tag_podcast}
|| ( $opt->{tag_podcast_radio} && ! $tags->{is_video} )
|| ( $opt->{tag_podcast_tv} && $tags->{is_video} );
return $tags;
}
# add metadata tag to file
sub tag_file {
my ($self, $meta) = @_;
my $tags = $self->tags_from_metadata($meta);
# dispatch to appropriate tagging function
if ( $meta->{filename} =~ /\.(mp3)$/i ) {
return $self->tag_file_id3($meta, $tags);
} elsif ( $meta->{filename} =~ /\.(mp4|m4v|m4a)$/i ) {
return $self->tag_file_mp4($meta, $tags);
} else {
main::logger "WARNING: Don't know how to tag \U$meta->{ext}\E file\n" if $opt->{verbose};
}
}
# add full ID3 tag with MP3::Tag
sub tag_file_id3 {
my ($self, $meta, $tags) = @_;
# look for required module
eval 'use MP3::Tag';
if ( $@ ) {
if ( $opt->{verbose} ) {
main::logger "INFO: Install the MP3::Tag module for full taggging of \U$meta->{ext}\E files\n";
main::logger "INFO: Falling back to ID3 BASIC taggging of \U$meta->{ext}\E files\n";
}
return $self->tag_file_id3_basic($meta, $tags);
}
eval {
main::logger "INFO: ID3 tagging \U$meta->{ext}\E file\n";
# translate podcast flag
$tags->{podcastFlag} = "\x01";
# remove existing tag(s) to avoid decoding errors
my $mp3 = MP3::Tag->new($meta->{filename});
$mp3->get_tags();
$mp3->{ID3v1}->remove_tag() if exists $mp3->{ID3v1};
$mp3->{ID3v2}->remove_tag() if exists $mp3->{ID3v2};
$mp3->close();
# add metadata
$mp3 = MP3::Tag->new($meta->{filename});
$mp3->select_id3v2_frame_by_descr('TCOP', $tags->{copyright});
$mp3->select_id3v2_frame_by_descr('TIT2', $tags->{title});
$mp3->select_id3v2_frame_by_descr('TPE1', $tags->{artist});
$mp3->select_id3v2_frame_by_descr('TPE2', $tags->{albumArtist});
$mp3->select_id3v2_frame_by_descr('TALB', $tags->{album});
$mp3->select_id3v2_frame_by_descr('TIT1', $tags->{grouping});
$mp3->select_id3v2_frame_by_descr('TCOM', $tags->{composer});
$mp3->select_id3v2_frame_by_descr('TCON', $tags->{genre});
$mp3->select_id3v2_frame_by_descr('COMM(eng,#0)[]', $tags->{comment});
$mp3->select_id3v2_frame_by_descr('TYER', $tags->{tyer});
$mp3->select_id3v2_frame_by_descr('TDAT', $tags->{tdat});
$mp3->select_id3v2_frame_by_descr('TIME', $tags->{time});
$mp3->select_id3v2_frame_by_descr('TRCK', $tags->{tracknum});
$mp3->select_id3v2_frame_by_descr('TPOS', $tags->{disk});
$mp3->select_id3v2_frame_by_descr('USLT', $tags->{lyrics});
# tag iTunes podcast
if ( $tags->{is_podcast} ) {
# ID3v2.4 only, but works in iTunes
$mp3->select_id3v2_frame_by_descr('TDRL', $tags->{year});
# ID3v2.3 and ID3v2.4
$mp3->select_id3v2_frame_by_descr('TIT3', $tags->{description});
# Neither ID3v2.3 nor ID3v2.4, but work in iTunes
$mp3->select_id3v2_frame_by_descr('TDES', $tags->{longDescription});
$mp3->{ID3v2}->add_raw_frame('PCST', $tags->{podcastFlag});
$mp3->select_id3v2_frame_by_descr('TCAT', $tags->{category});
$mp3->select_id3v2_frame_by_descr('TKWD', $tags->{keyword});
$mp3->select_id3v2_frame_by_descr('TGID', $tags->{podcastGUID});
}
# add artwork if available
if ( -f $meta->{thumbfile} ) {
my $data;
open(THUMB, $meta->{thumbfile});
binmode(THUMB);
read(THUMB, $data, stat($meta->{thumbfile})->size());
close(THUMB);
$mp3->select_id3v2_frame_by_descr('APIC', $data);
}
# write metadata to file
$mp3->update_tags();
$mp3->close();
};
if ( $@ ) {
main::logger "ERROR: Failed to tag \U$meta->{ext}\E file\n";
main::logger "ERROR: $@" if $opt->{verbose};
# clean up thumbnail if necessary
unlink $meta->{thumbfile} if ! $opt->{thumb};
return 4;
}
}
# add basic ID3 tag with id3v2
sub tag_file_id3_basic {
my ($self, $meta, $tags) = @_;
if ( main::exists_in_path('id3v2') ) {
main::logger "INFO: ID3 BASIC tagging \U$meta->{ext}\E file\n";
# notify about limitations of basic tagging
if ( $opt->{verbose} ) {
main::logger "INFO: ID3 BASIC tagging cannot add artwork to \U$meta->{ext}\E files\n";
main::logger "INFO: ID3 BASIC tagging cannot add podcast metadata to \U$meta->{ext}\E files\n" if $tags->{is_podcast};
}
# colons are parsed as frame field separators by id3v2
# so replace them to make safe comment text
$tags->{comment} =~ s/:/_/g;
# make safe lyrics text as well
# can't use $tags->{lyrics} because of colons in links
$tags->{longDescription} =~ s/:/_/g;
# encode for id3v2
while ( my ($key, $val) = each %{$tags} ) {
$tags->{$key} = encode("iso-8859-1", $val);
}
# build id3v2 command
my @cmd = (
$bin->{id3v2},
'--TCOP', $tags->{copyright},
'--TIT2', $tags->{title},
'--TPE1', $tags->{artist},
'--TPE2', $tags->{albumArtist},
'--TALB', $tags->{album},
'--TIT1', $tags->{grouping},
'--TCOM', $tags->{composer},
'--TCON', $tags->{genre},
'--COMM', $tags->{comment},
'--TYER', $tags->{tyer},
'--TDAT', $tags->{tdat},
'--TIME', $tags->{time},
'--TRCK', $tags->{tracknum},
'--TPOS', $tags->{disk},
'--USLT', $tags->{longDescription},
$meta->{filename},
);
# run id3v2 command
if ( main::run_cmd( 'STDERR', @cmd ) ) {
main::logger "WARNING: Failed to tag \U$meta->{ext}\E file\n";
return 2;
}
} else {
main::logger "WARNING: Cannot tag \U$meta->{ext}\E file\n" if $opt->{verbose};
}
}
# add MP4 tag with atomicparsley
sub tag_file_mp4 {
my ($self, $meta, $tags) = @_;
# Only tag if the required tool exists
if ( main::exists_in_path( 'atomicparsley' ) ) {
main::logger "INFO: MP4 tagging \U$meta->{ext}\E file\n";
# pretty copyright for MP4
$tags->{copyright} = "\xA9 $tags->{copyright}" if $tags->{copyright};
# encode metadata for atomicparsley
my $encoding = $opt->{tag_utf8} ? "utf8" : "iso-8859-1";
while ( my ($key, $val) = each %$tags ) {
$tags->{$key} = encode($encoding, $val);
}
# build atomicparsley command
my @cmd = (
$bin->{atomicparsley},
$meta->{filename},
'--freefree',
'--overWrite',
'--stik', $tags->{stik},
'--advisory', $tags->{advisory},
'--copyright', $tags->{copyright},
'--title', $tags->{title},
'--artist', $tags->{artist},
'--albumArtist', $tags->{albumArtist},
'--album', $tags->{album},
'--grouping', $tags->{grouping},
'--composer', $tags->{composer},
'--genre', $tags->{genre},
'--comment', $tags->{comment},
'--year', $tags->{year},
'--tracknum', $tags->{tracknum},
'--disk', $tags->{disk},
'--lyrics', $tags->{lyrics},
);
# add descriptions to audio podcasts and video
if ( $tags->{is_video} || $tags->{is_podcast}) {
push @cmd, ('--description', $tags->{description} );
if ( $opt->{tag_longdescription} ) {
push @cmd, ( '--longDescription', $tags->{longDescription} );
} elsif ( $opt->{tag_longdesc} ) {
push @cmd, ( '--longdesc', $tags->{longDescription} );
}
}
# video only
if ( $tags->{is_video} ) {
# all video
push @cmd, ( '--hdvideo', $tags->{hdvideo} ) if $opt->{tag_hdvideo};
# tv only
if ( $tags->{is_tvshow} ) {
push @cmd, (
'--TVShowName', $tags->{TVShowName},
'--TVEpisode', $tags->{TVEpisode},
'--TVSeasonNum', $tags->{TVSeasonNum},
'--TVEpisodeNum', $tags->{TVEpisodeNum},
'--TVNetwork', $tags->{TVNetwork},
);
}
}
# tag iTunes podcast
if ( $tags->{is_podcast} ) {
push @cmd, (
'--podcastFlag', $tags->{podcastFlag},
'--category', $tags->{category},
'--keyword', $tags->{keyword},
'--podcastGUID', $tags->{podcastGUID},
);
}
# add artwork if available
push @cmd, ( '--artwork', $meta->{thumbfile} ) if -f $meta->{thumbfile};
# run atomicparsley command
if ( main::run_cmd( 'STDERR', @cmd ) ) {
main::logger "WARNING: Failed to tag \U$meta->{ext}\E file\n";
return 2;
}
} else {
main::logger "WARNING: Cannot tag \U$meta->{ext}\E file\n" if $opt->{verbose};
}
}
############## End OO ##############