#!/usr/bin/env perl # # The world's most insecure web-based PVR manager and streaming proxy for get_iplayer # ** WARNING ** Never run this in an untrusted environment or facing the internet # # Copyright (C) 2009-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://www.infradead.org/get_iplayer/html/get_iplayer.html # License: GPLv3 (see LICENSE.txt) # my $VERSION = 2.99; my $VERSION_TEXT; $VERSION_TEXT = sprintf("v%.2f", $VERSION) unless $VERSION_TEXT; use strict; use CGI qw(-utf8 :all); use CGI::Cookie; use IO::File; use File::Copy; use HTML::Entities; use LWP::ConnCache; #use LWP::Debug qw(+); use LWP::UserAgent; use IO::Handle; use Getopt::Long; use Cwd 'abs_path'; use File::Basename; use Encode qw(:DEFAULT :fallback_all); use PerlIO::encoding; $PerlIO::encoding::fallback = XMLCREF; use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0; # suppress Perl 5.22/CGI 4 warning $CGI::LIST_CONTEXT_WARN = 0; $| = 1; my $fh; # Send log messages to this fh my $se = *STDERR; binmode $se, ':utf8'; my $opt_cmdline; $opt_cmdline->{debug} = 0; # Allow bundling of single char options Getopt::Long::Configure ("bundling"); # cmdline opts take precedence GetOptions( "help|h" => \$opt_cmdline->{help}, "listen|address|l=s" => \$opt_cmdline->{listen}, "port|p=n" => \$opt_cmdline->{port}, "getiplayer|get_iplayer|g=s" => \$opt_cmdline->{getiplayer}, "ffmpeg=s" => \$opt_cmdline->{ffmpeg}, "encodinglocalefs|encoding-locale-fs=s" => \$opt_cmdline->{encodinglocalefs}, "debug" => \$opt_cmdline->{debug}, ) || die usage(); # Display usage if old method of invocation is used or --help usage() if $opt_cmdline->{help} || @ARGV; # Usage sub usage { my $text = "get_iplayer Web PVR Manager $VERSION_TEXT, "; $text .= <<'EOF'; Copyright (C) 2009-2010 Phil Lewis This program comes with ABSOLUTELY NO WARRANTY; This is free software, and you are welcome to redistribute it under certain conditions; See the GPLv3 for details. Options: --listen,-l Use the built-in web server and listen on this interface address (default: 0.0.0.0) --port,-p Use the built-in web server and listen on this TCP port --getiplayer,-g Path to the get_iplayer script --ffmpeg Path to the ffmpeg binary --encodinglocalefs Encoding for file names (default: Linux/Unix/OSX = UTF-8, Windows = cp1252) --debug Debug mode --help,-h This help text EOF print $text; exit 1; } # Some defaults my $default_modes = 'default'; $opt_cmdline->{listen} = '0.0.0.0' if ! $opt_cmdline->{listen}; # Search for get_iplayer if ( ! $opt_cmdline->{getiplayer} ) { for ( './get_iplayer', './get_iplayer.cmd', './get_iplayer.pl', '/usr/bin/get_iplayer', '/usr/local/bin/get_iplayer' ) { $opt_cmdline->{getiplayer} = $_ if -x $_; } } if ( ( ! $opt_cmdline->{getiplayer} ) || ! -f $opt_cmdline->{getiplayer} ) { print "ERROR: Cannot find get_iplayer, please specify its location using the --getiplayer option.\n"; exit 2; } $opt_cmdline->{encodinglocalefs} ||= (IS_WIN32 ? 'cp1252' : 'utf8'); $opt_cmdline->{ffmpeg} ||= 'ffmpeg'; # Path to get_iplayer (+ set HOME env var cos apache seems to not set it) my $home = $ENV{HOME}; my %prog; my @pids; my @displaycols; # Field names to be grabbed from get_iplayer my @headings = qw( index thumbnail pid available expires type name episode versions duration desc channel categories timeadded guidance web seriesnum episodenum filename mode ); # Default Displayed headings my @headings_default = qw( thumbnail type name episode desc channel categories timeadded ); # Lookup table for nice field name headings my %fieldname = ( index => 'Index', pid => 'Pid', available => 'Availability', expires => 'Expires', type => 'Type', name => 'Name', episode => 'Episode', versions => 'Versions', duration => 'Duration', desc => 'Description', channel => 'Channel', categories => 'Categories', thumbnail => 'Image', timeadded => 'Time Added', guidance => 'Guidance', web => 'Web Page', pvrsearch => 'PVR Search', comment => 'Comment', filename => 'Filename', mode => 'Mode', seriesnum => 'Series Number', episodenum => 'Episode Number', 'name,episode' => 'Name+Episode', 'name,episode,desc' => 'Name+Episode+Desc', ); my %cols_order = (); my %cols_names = (); my %prog_types = ( tv => 'BBC TV', radio => 'BBC Radio' ); my %prog_types_order = ( 1 => 'tv', 2 => 'radio' ); my $icons_base_url = './icons/'; my $cgi; my $nextpage; # Page routing based on NEXTPAGE CGI parameter my %nextpages = ( 'search_progs' => \&search_progs, # Main Programme Listings 'search_history' => \&search_history, # Recorded Programme Listings 'pvr_queue' => \&pvr_queue, # Queue Recording of Selected Progs 'recordings_delete' => \&recordings_delete, # Delete Files for Selected Recordings 'pvr_list' => \&show_pvr_list, # Show all current PVR searches 'pvr_del' => \&pvr_del, # Delete selected PVR searches 'pvr_add' => \&pvr_add, 'pvr_edit' => \&pvr_edit, 'pvr_save' => \&pvr_save, 'pvr_run' => \&pvr_run, 'record_now' => \&record_now, 'show_info' => \&show_info, 'refresh' => \&refresh, ); ##### Options ##### my $opt; # Options Layout on page tabs my $layout; $layout->{BASICTAB}->{title} = 'Search Options', $layout->{BASICTAB}->{heading} = 'Search Options:', $layout->{BASICTAB}->{order} = [ qw/ SEARCH SEARCHFIELDS PROGTYPES HISTORY URL / ]; $layout->{SEARCHTAB}->{title} = 'Advanced Search'; $layout->{SEARCHTAB}->{heading} = 'Advanced Search Options:'; $layout->{SEARCHTAB}->{order} = [ qw/ EXCLUDE CATEGORY EXCLUDECATEGORY CHANNEL EXCLUDECHANNEL SINCE BEFORE FUTURE / ], $layout->{DISPLAYTAB}->{title} = 'Display'; $layout->{DISPLAYTAB}->{heading} = 'Display Options:'; $layout->{DISPLAYTAB}->{order} = [ qw/ SORT REVERSE PAGESIZE HIDE HIDEDELETED / ]; $layout->{COLUMNSTAB}->{title} = 'Columns'; $layout->{COLUMNSTAB}->{heading} = 'Column Options:'; $layout->{COLUMNSTAB}->{order} = [ qw/ COLS / ]; $layout->{RECORDINGTAB}->{title} = 'Recording'; $layout->{RECORDINGTAB}->{heading} = 'Recording Options:'; $layout->{RECORDINGTAB}->{order} = [ qw/ OUTPUT VERSIONLIST MODES PROXY SUBTITLES METADATA THUMB PVRHOLDOFF FORCE AUTOWEBREFRESH AUTOPVRRUN REFRESHFUTURE / ]; $layout->{STREAMINGTAB}->{title} = 'Streaming'; $layout->{STREAMINGTAB}->{heading} = 'Streaming Options:'; $layout->{STREAMINGTAB}->{order} = [ qw/ BITRATE VSIZE VFR STREAMTYPE / ]; $layout->{HIDDENTAB}->{title} = ''; $layout->{HIDDENTAB}->{heading} = ''; $layout->{HIDDENTAB}->{order} = [ qw/ SAVE SEARCHTAB COLUMNSTAB DISPLAYTAB RECORDINGTAB STREAMINGTAB PAGENO INFO NEXTPAGE ACTION / ]; # Order of displayed tab buttoms (BASICTAB and HIDDEN are always displayed regardless of order) $layout->{taborder} = [ qw/ BASICTAB SEARCHTAB DISPLAYTAB COLUMNSTAB RECORDINGTAB STREAMINGTAB HIDDENTAB / ]; # Any params that should never get into the get_iplayer pvr-add search my @nosearch_params = qw/ /; ### Perl CGI Web Server ### use Socket; use IO::Socket; use POSIX ":sys_wait_h"; my $IGNOREEXIT = 0; # If the port number is specified then run embedded web server if ( $opt_cmdline->{port} > 0 ) { # Autoreap zombies $SIG{CHLD} = 'IGNORE'; # Need this because with $SIG{CHLD} = 'IGNORE', backticks and systems calls always return -1 $IGNOREEXIT = 1; for (;;) { # Setup and create socket my $server = new IO::Socket::INET( Proto => 'tcp', LocalAddr => $opt_cmdline->{listen}, LocalPort => $opt_cmdline->{port}, Listen => SOMAXCONN, Reuse => 1, ); $server or die "Unable to create server socket: $!"; print $se "INFO: Listening on $opt_cmdline->{listen}:$opt_cmdline->{port}\n"; print $se "WARNING: Insecure Remote access is allowed, use --listen=127.0.0.1 to limit to this host only\n" if $opt_cmdline->{listen} ne '127.0.0.1'; # Await requests and handle them as they arrive while (my $client = $server->accept()) { my $procid = fork(); die "Cannot fork" unless defined $procid; # Parent if ( $procid ) { close $client; # must call waitpid() on Windows if ( IS_WIN32 ) { while ( abs(waitpid(-1, WNOHANG)) > 1 ) {} } next; } # Child binmode $se, IS_WIN32 ? ":encoding(cp1252)" : ':encoding(UTF-8)'; $client->autoflush(1); my %request = (); my $query_string; my %data; { # Read Request local $/ = Socket::CRLF; while (<$client>) { # Main http request chomp; if (/\s*(\w+)\s*([^\s]+)\s*HTTP\/(\d.\d)/) { $request{METHOD} = uc $1; $request{URL} = $2; $request{HTTP_VERSION} = $3; # Standard headers } elsif (/:/) { my ( $type, $val ) = split /:/, $_, 2; $type =~ s/^\s+//; for ($type, $val) { s/^\s+//; s/\s+$//; } $request{lc $type} = $val; print "REQUEST HEADER: $type: $val\n" if $opt_cmdline->{debug}; # POST data } elsif (/^$/) { read( $client, $request{CONTENT}, $request{'content-length'} ) if defined $request{'content-length'}; last; } } } # Determine method and parse parameters if ($request{METHOD} eq 'GET') { if ($request{URL} =~ /(.*)\?(.*)/) { $request{URL} = $1; $request{CONTENT} = $2; $query_string = $request{CONTENT}; } $data{"_method"} = "GET"; } elsif ($request{METHOD} eq 'POST') { $query_string = parse_post_form_string( $request{CONTENT} ); $data{"_method"} = "POST"; } else { $data{"_method"} = "ERROR"; } # Log Request print $se "$data{_method}: $request{URL}\n"; # Is this the CGI or some other file request? if ( $request{URL} =~ /^\/?(iplayer|recordings_delete|playlist.*|genplaylist.*|opml|)\/?$/ ) { # remove any vars that might affect the CGI #%ENV = (); @ARGV = (); # Setup CGI http vars print $se "QUERY_STRING = $query_string\n" if defined $query_string; $ENV{'QUERY_STRING'} = $query_string; $ENV{'REQUEST_URI'} = $request{URL}; $ENV{'COOKIE'} = $request{cookie}; $ENV{'SERVER_PORT'} = $opt_cmdline->{port}; # respond OK to browser print $client "HTTP/1.1 200 OK", Socket::CRLF; # Invoke CGI run_cgi( $client, $query_string, $request{URL}, 'http://'.$request{host}.'/' ); # Else 404 } else { print $se "ERROR: 404 Not Found\n"; print $client "HTTP/1.1 404 Not Found", Socket::CRLF; print $client Socket::CRLF; print $client "404 Not Found"; $data{"_status"} = "404"; } # Close Connection close $client; # Exit child exit 0; } } # If we're running as a proper CGI from a web server... } else { # If we were called by a webserver and not the builtin webserver then seed some vars my $prefix = $ENV{REQUEST_URI}; my $request_uri; # remove trailing query $prefix =~ s/\?.*$//gi; my $query_string = $ENV{QUERY_STRING}; my $request_host = "http://$ENV{SERVER_NAME}:$ENV{SERVER_PORT}${prefix}"; # determine whether http or https my $request_protocol = 'http'; if ( defined $ENV{'HTTPS'} ) { $request_protocol = $ENV{'HTTPS'}=='on'?'https':'http'; } my $request_host = "${request_protocol}://$ENV{SERVER_NAME}:$ENV{SERVER_PORT}${prefix}"; $home = $ENV{HOME}; # Read POSTed data from STDIN if this is a form POST if ( $ENV{REQUEST_METHOD} eq 'POST' ) { my $content; while ( ) { $content .= $_; } $query_string = parse_post_form_string( $content ); } run_cgi( *STDOUT, $query_string, undef, $request_host ); } exit 0; sub cleanup { my $signal = shift; print $se "INFO: Cleaning up PID $$ (signal = $signal)\n"; exit 0; } # wrap HTML::Entities::encode_entities to limit encoding sub encode_entities { my $value = shift; return HTML::Entities::encode_entities( $value, '&<>"\'' ); } sub parse_post_form_string { my $form = $_[0]; my @data; while ( $form =~ /Content-Disposition:(.+?)--/sg ) { $_ = $1; # form-data; name = "KEY" m{name.+?"(.+?)"[\n\r\s]*(.+)}sg; my ($key, $val) = ( $1, $2 ); next if ! $1; $val =~ s/[\r\n]//g; $val =~ s/\+/ /g; # Decode entities first decode_entities($val); # url encode each entry # $val =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg; $val = CGI::escape($val); push @data, "$key=$val"; } return join '&', @data; } sub run_cgi { # Get filehandle for output $fh = shift; binmode $fh, ':utf8'; my $query_string = shift; my $request_uri = shift; my $request_host = shift; # Clean globals %prog = (); @pids = (); @displaycols = (); # new cgi instance $cgi->delete_all() if defined $cgi; $cgi = new CGI( $query_string ); # Get next page $nextpage = $cgi->param( 'NEXTPAGE' ) || 'search_progs'; # Process All options process_params(); # Set HOME env var for forked processes $ENV{HOME} = $home; my $action = $cgi->param( 'ACTION' ) || $request_uri; # Strip the leading '/' to get the action $action =~ s|^\/||g; # rewrite short-form backwards compatible URIs # e.g. http://server/stream?args -> http://server/get_iplayer.cgi?ACTION=stream&args # Stream from get_iplayer STDOUT (optionally transcoding if required) if ( $action eq 'direct' ) { binmode $fh, ':raw'; # get filename first my $progtype = $cgi->param( 'PROGTYPES' ); my $pid = $cgi->param( 'PID' ); # If the modes list f set to nothing #my $mode = $opt->{MODES}->{current} || $opt->{MODES}->{default}; my $mode = $cgi->param( 'MODES' ); my $filename = get_direct_filename( $pid, $mode, $progtype ); # Use OUTTYPE for transcoding if required - get output ext # $cgi->param('STREAMTYPE') || $cgi->param('OUTTYPE') || 'flv' if $action eq 'playlistdirect'; my $ext = lc( $cgi->param('STREAMTYPE') || $cgi->param( 'OUTTYPE' ) ); # Remove fileprefix $ext =~ s/^.*\.//g; # get file source ext my $src_ext = $filename; $src_ext =~ s/^.*\.//g; # Stream mime types my %mimetypes = ( wav => 'audio/x-wav', flac => 'audio/x-flac', aac => 'audio/mpeg', m4a => 'audio/mpeg', mp3 => 'audio/mpeg', rm => 'audio/x-pn-realaudio', mov => 'video/quicktime', mp4 => 'video/mp4', avi => 'video/x-flv', flv => 'video/x-flv', asf => 'video/x-ms-asf', ); # default recipies # Disable transcoding if none is specified as OUTTYPE/STREAMTYPE my $notranscode = 0; if ( $ext =~ /none/i ) { print $se "INFO: Transcoding disabled (OUTTYPE=none)\n"; $ext = $src_ext; $notranscode = 1; # cannot stream mp4/avi so transcode to flv # Add types here which you want re-muxed into flv #if ( $src_ext =~ m{^(mp4|avi|mov|mp3|aac)$} && ! $ext ) { } elsif ( $src_ext =~ m{^(mp4|m4a|aac|avi|mov)$} && ! $ext ) { $ext = 'flv'; # Else Default to no transcoding } elsif ( ! $ext ) { $ext = $src_ext; } print $se "INFO: Streaming OUTTYPE:$ext MIMETYPE=$mimetypes{$ext} FILE:$filename to client\n"; # If type is defined if ( $mimetypes{$ext} ) { # Output headers # to stream # This will enable seekable -Accept_Ranges=>'bytes', my $headers = $cgi->header( -type => $mimetypes{$ext}, -Connection => 'close' ); # Send the headers to the browser print $se "\r\nHEADERS:\n$headers\n"; #if $opt_cmdline->{debug}; print $fh $headers; stream_file( $filename, $mimetypes{$ext}, $src_ext, $ext, $notranscode, $cgi->param( 'BITRATE' ), $cgi->param( 'VSIZE' ), $cgi->param( 'VFR' ) ); } else { print $se "ERROR: Aborting client thread - output mime type is undetermined\n"; } # Get a playlist for a specified 'PROGTYPES' } elsif ( $action eq 'playlist' || $action eq 'playlistdirect' || $action eq 'playlistfiles' ) { # Output headers my $headers = $cgi->header( -type => 'audio/x-mpegurl' ); # Send the headers to the browser print $se "\r\nHEADERS:\n$headers\n"; #if $opt_cmdline->{debug}; print $fh $headers; # determine output type my $outtype = $cgi->param('OUTTYPE') || 'flv'; $outtype = $cgi->param('STREAMTYPE') || $cgi->param('OUTTYPE') || 'flv' if $action eq 'playlistdirect'; # ( host, outtype, modes, progtype, bitrate, search, searchfields, action ) print $fh create_playlist_m3u_single( $request_host, $outtype, $opt->{MODES}->{current}, $opt->{PROGTYPES}->{current} , $cgi->param('BITRATE') || '', $opt->{SEARCH}->{current}, $opt->{SEARCHFIELDS}->{current} || 'name', $opt->{VERSIONLIST}->{current}, $action ); # Get a playlist for a specified 'PROGTYPES' } elsif ( $action eq 'opml' ) { # Output headers my $headers = $cgi->header( -type => 'text/xml' ); # Send the headers to the browser print $se "\r\nHEADERS:\n$headers\n"; #if $opt_cmdline->{debug}; print $fh $headers; # ( host, outtype, modes, type, bitrate ) print $fh get_opml( $request_host, $cgi->param('OUTTYPE') || 'flv', $opt->{MODES}->{current}, $opt->{PROGTYPES}->{current} , $cgi->param('BITRATE') || '', $opt->{SEARCH}->{current}, $cgi->param('LIST') || '' ); # Get a playlist for a selected progs in form } elsif ( $action eq 'genplaylist' || $action eq 'genplaylistdirect' || $action eq 'genplaylistfile' ) { # Output headers my $headers = $cgi->header( -type => 'audio/x-mpegurl' ); # To save file #my $headers = $cgi->header( -type => 'audio/x-mpegurl', -attachment => 'get_iplayer.m3u' ); # Send the headers to the browser print $se "\r\nHEADERS:\n$headers\n"; #if $opt_cmdline->{debug}; print $fh $headers; # determine output type my $outtype = $cgi->param('OUTTYPE') || 'flv'; $outtype = $cgi->param('STREAMTYPE') || $cgi->param('OUTTYPE') if $action eq 'genplaylistdirect'; # ( host, outtype, modes, bitrate, action ) print $fh create_playlist_m3u_multi( $request_host, $outtype, $cgi->param('BITRATE') || '', $action ); # HTML page } else { # Output header and html start begin_html( $request_host ); # Page Routing form_header( $request_host ); #print $fh $cgi->Dump(); if ( $opt_cmdline->{debug} ) { print $fh $cgi->Dump(); #for my $key (sort keys %ENV) { # print $fh $key, " = ", $ENV{$key}, "\n"; #} } if ($nextpages{$nextpage}) { # call the correct subroutine $nextpages{$nextpage}->(); } form_footer(); html_end(); } $cgi->delete_all(); return 0; } sub pvr_run { print $fh "

The PVR will auto-run every $opt->{AUTOPVRRUN}->{current} hour(s) if you leave this page open

" if $opt->{AUTOPVRRUN}->{current}; if ( IS_WIN32 ) { print $fh "

Windows users: You may encounter errors if you perform other tasks in the Web PVR Manager while this page is reloading

" if $opt->{AUTOPVRRUN}->{current}; } print $se "INFO: Starting PVR Run\n"; my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nopurge', '--nocopyright', '--hash', '--pvr', ); #print $se "DEBUG: running: $cmd\n"; print $fh '
';
	# Redirect both STDOUT and STDERR to client browser socket
	run_cmd_autorefresh( $fh, $fh, 1, @cmd );
	print $fh '
'; print $fh p("PVR Run complete"); # Load the refresh tab if required my $autopvrrun = $cgi->cookie( 'AUTOPVRRUN' ) || $cgi->param( 'AUTOPVRRUN' ); # Render options actions print $fh div( { -class=>'action' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ a( { -class=>'action', -title => 'Run PVR Now', -onClick => "RefreshTab( '?NEXTPAGE=pvr_run&AUTOPVRRUN=$autopvrrun', ".(1000*3600*$autopvrrun).", 1 );", }, 'PVR Run Now' ), a( { -class=>'action', -title => 'Close', -onClick => "window.close()", }, 'Close' ), ]), ), ); } sub record_now { my @record; # The 'Record' action button uses SEARCH to pass it's pvr_queue data if ( $cgi->param( 'SEARCH' ) ) { push @record, $cgi->param( 'SEARCH' ); } else { @record = ( $cgi->param( 'PROGSELECT' ) ); } my @params = get_search_params(); my $out; # If a URL was specified by the User (assume auto mode list is OK): if ( $opt->{URL}->{current} =~ m{^http://} ) { push @record, "$opt->{PROGTYPES}->{current}|$opt->{URL}->{current}|$opt->{URL}->{current}|-"; } print $fh "

Please leave this page open until the recording completes

"; # Render options actions print $fh div( { -class=>'action' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ a( { -class=>'action', -title => 'Close', -onClick => "window.close()", }, 'Close' ), ]), ), ); print $fh "

Recording The Following Programmes


\n"; print $se "INFO: Starting Recording Now\n"; # Queue all selected 'TYPE|PID|NAME|EPISODE|MODE|CHANNEL' entries in the PVR for (@record) { chomp(); my ( $type, $pid, $name, $episode ) = (split /\|/)[0,1,2,3]; next if ! ($type && $pid ); my $comment = "$name - $episode"; my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nopurge', '--nocopyright', '--expiry=999999999', '--hash', '--webrequest', get_iplayer_webrequest_args( "pid=$pid", "type=$type", build_cmd_options( grep !/^(HISTORY|SINCE|BEFORE|HIDEDELETED|FUTURE|SEARCH|SEARCHFIELDS|PROGTYPES|EXCLUDEC.+)$/, @params ) ), ); print $fh p("Command: ".( join ' ', @cmd ) ) if $opt_cmdline->{debug}; print $fh '
';
		# Redirect both STDOUT and STDERR to client browser socket
		run_cmd_autorefresh( $fh, $fh, 1, @cmd );
		print $fh '
'; } print $fh p("Recording complete"); return 0; } # Stream a file to browser/client sub stream_file { my ( $filename, $mimetype, $src_ext, $ext, $notranscode, $abitrate, $vsize, $vfr ) = ( @_ ); print $se "INFO: Start Direct Streaming $filename to browser using mimetype '$mimetype', output ext '$ext', audio bitrate '$abitrate', video size '$vsize', video frame rate '$vfr'\n"; # If transcoding required (i.e. output ext != source ext) - OR, if one of the transcoing options is set if ( ( ! $notranscode ) && ( lc( $ext ) ne lc( $src_ext ) || $abitrate || $vsize || $vfr ) ) { $fh->autoflush(0); my @cmd = build_ffmpeg_args( $filename, $mimetype, $ext, $abitrate, $vsize, $vfr, $src_ext ); run_cmd( $fh, $se, 100000, @cmd ); print $se "INFO: Finished Streaming and transcoding $filename to browser\n"; } else { print $se "INFO: Streaming file directly: $filename\n"; if ( ! open( STREAMIN, "< $filename" ) ) { print $se "INFO: Cannot Read file '$filename'\n"; exit 4; } # Read each char from command output and push to socket fh my $char; my $bytes; # Assume that we don't want to buffer STDERR output of the command my $size = 100000; while ( $bytes = read( STREAMIN, $char, $size ) ) { if ( $bytes <= 0 ) { close STREAMIN; print $se "DEBUG: Stream thread has completed\n"; exit 0; } else { print $fh $char; print $se '#'; } last if $bytes < $size; } close STREAMIN; print $se "INFO: Finished Streaming $filename to browser\n"; } return 0; } sub build_ffmpeg_args { my ( $filename, $mimetype, $ext, $abitrate, $vsize, $vfr, $src_ext ) = ( @_ ); my @cmd_aopts; my $src_mimetype = $mimetype; # mime type override for audio->flv conversion if ( lc( $src_ext ) =~ m{^(aac|m4a|mp3)$} ) { $src_mimetype = 'audio/mpeg'; } if ( $abitrate =~ m{^\d+$} ) { if ( lc( $ext ) eq 'flv' ) { push @cmd_aopts, ( '-ar', '44100', '-ab', "${abitrate}k" ); } else { push @cmd_aopts, ( '-ab', "${abitrate}k" ); } } else { if ( lc( $ext ) eq 'flv' ) { push @cmd_aopts, ( '-ar', '44100' ); } # cannot copy code if for example we have an aac stream output as WAV (e.g. squeezebox flashaac) #push @cmd_aopts, ( '-acodec', 'copy' ); } my @cmd; # If conversion is necessary # Video if ( $src_mimetype =~ m{^video} ) { my @cmd_vopts; # Apply video size push @cmd_vopts, ( '-s', "${vsize}" ) if $vsize =~ m{^\d+x\d+$}; # Apply video framerate - caveat - bitrate defaults to 200k if only vfr is set push @cmd_vopts, ( '-r', $vfr ) if $vfr =~ m{^\d$}; # -sameq is bad ## Apply sameq if framerate only and no bitrate #push @cmd_vopts, '-sameq' if $vfr =~ m{^\d$} && $vsize !~ m{^\d+x\d+$}; # Add in the codec if we are transcoding and not remuxing the stream if ( @cmd_vopts ) { push @cmd_vopts, ( '-vcodec', 'libx264' ); } else { push @cmd_vopts, ( '-vcodec', 'copy' ); } @cmd = ( $opt_cmdline->{ffmpeg}, #'-f', $src_ext, # not required? '-i', $filename, @cmd_aopts, @cmd_vopts, '-f', $ext, '-', ); # Audio } else { @cmd = ( $opt_cmdline->{ffmpeg}, #'-f', $src_ext, # not required? '-i', $filename, '-vn', @cmd_aopts, '-ac', 2, '-f', $ext, '-', ); } print $se "DEBUG: Command args: ".(join ' ', @cmd)."\n"; return @cmd; } sub create_playlist_m3u_single { my ( $request_host, $outtype, $modes, $type, $bitrate, $search, $searchfields, $versionlist, $request ) = ( @_ ); my @playlist; $outtype =~ s/^.*\.//g; my $searchterm = $search; # this is already a wildcard default regex... if ( $search eq '.*' ) { $searchterm = '.*'; # if it's a URL then bypass regex stuff } elsif ( $search =~ m{^http} ) { $searchterm = $search; # make search term regex friendly } else { $searchterm =~ s|([\/\.\?\+\-\*\^\(\)\[\]\{\}])|\\$1|g; } print $se "INFO: Getting playlist for type '$type' using modes '$modes' and bitrate '$bitrate'\n"; my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( 'nopurge=1', "type=$type", 'listformat=ENTRY||||||', "fields=$searchfields", "search=$searchterm", "versionlist=$versionlist" ), ); # Only add history search if the request is of this type or is a PlayFile from localfiles type if ( ( $request eq 'playlistfiles' || $request eq 'playlistdirect' ) && ! ( $search =~ m{^/} && $searchfields eq 'pid' ) ) { push @cmd, '--history', '--skipdeleted'; } my @out = get_cmd_output( @cmd ); push @playlist, "#EXTM3U\n"; # Extract and rewrite into m3u format # /home/lewispj/mp3/Rock/radiohead/Ok Computer/radiohead - (07) fitter happier.mp3||(07) Fitter Happier|, , (256kbps/44.1kHz)|| for ( grep !/^(Added:|Matches|$)/ , @out ) { chomp(); my $url; my ( $pid, $name, $episode, $desc, $filename, $mode, $channel ) = (split /\|/)[1,2,3,4,5,6,7]; #print $se "DEBUG: $pid, $name, $episode, $desc, $filename, $mode\n"; # sanitze modes && filename $mode = '' if $mode eq ''; $filename = '' if $filename eq ''; # playlist with direct streaming for files through webserver if ( $request eq 'playlistdirect' ) { next if ! ( $pid && $type && $mode ); $url = build_url_direct( $request_host, $type, $pid, $mode, basename( $filename ), $opt->{STREAMTYPE}->{current}, $opt->{HISTORY}->{current}, $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ); # If pid is actually a filename then use it cos this is a local file type programme } elsif ( $request eq 'playlistfiles' && $pid =~ m{^/} ) { next if ! $pid; $url = search_absolute_path( $pid ) if $pid; # playlist with local files } elsif ( $request eq 'playlistfiles' ) { next if ! $filename; $url = search_absolute_path( $filename ); # playlist of proxied urls for streaming online prog via web server } else { next if ! ( $type && $pid ); my $suffix = "${pid}.${outtype}"; $url = build_url_stream( $request_host, $type, $pid, $mode || $modes, $suffix, $opt->{STREAMTYPE}->{current}, $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ); } # Format required, e.g. ##EXTINF:-1,BBC Radio - BBC Radio One (High Quality Stream) push @playlist, "#EXTINF:-1,$type - $channel - $name - $episode - $desc"; push @playlist, "$url\n"; } print $se join ("\n", @playlist); return join ("\n", @playlist); } sub create_playlist_m3u_multi { my ( $request_host, $outtype, $bitrate, $request ) = ( @_ ); my @playlist; push @playlist, "#EXTM3U\n"; my @record = ( $cgi->param( 'PROGSELECT' ) ); # If a URL was specified by the User (assume auto mode list is OK): if ( $opt->{URL}->{current} =~ m{^http://} ) { push @record, "$opt->{PROGTYPES}->{current}|$opt->{URL}->{current}|$opt->{URL}->{current}|-"; } # Create m3u from all selected 'TYPE|PID|NAME|EPISODE|MODE|CHANNEL' entries in the PVR for (@record) { my $url; chomp(); my ( $type, $pid, $name, $episode, $mode, $channel ) = (split /\|/)[0,1,2,3,4,5]; next if ! ($type && $pid ); # playlist with direct streaming fo files through webserver if ( $request eq 'genplaylistdirect' ) { $url = build_url_direct( $request_host, $type, $pid, $mode, $outtype, $opt->{STREAMTYPE}->{current}, $opt->{HISTORY}->{current}, $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ); # playlist with local files } elsif ( $request eq 'genplaylistfile' ) { # If pid is actually a filename then use it cos this is a local file type programme if ( $pid =~ m{^/} ) { my $filename = search_absolute_path( $pid ); $url = $filename if $filename; } else { # Lookup filename (add it if defined - even if relative) # check for -f $filename if you want to exclude files that cannot be found my $filename = get_direct_filename( $pid, $mode, $type ); $url = $filename if $filename; } # Uncomment this to make all playlists local for localfiles types # If pid is actually a filename then use it cos this is a local file type programme #} elsif ( $pid =~ m{^/} ) { # my $filename = search_absolute_path( $pid ); # $url = $filename if $filename; # playlist of proxied urls for streaming online prog via web server } else { my $suffix = "${pid}.${outtype}"; $url = build_url_stream( $request_host, $type, $pid, $mode || $opt->{MODES}->{current}, $suffix, $opt->{STREAMTYPE}->{current}, $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ); } # Skip empty urls next if ! $url; # Format required, e.g. ##EXTINF:-1,BBC Radio - BBC Radio One (High Quality Stream) #http://localhost:1935/stream?PID=liveradio:bbc_radio_one&MODES=flashaac&OUTTYPE=bbc_radio_one.wav push @playlist, "#EXTINF:-1,$type - $channel - $name - $episode"; push @playlist, "$url\n"; } print $se join ("\n", @playlist); return join ("\n", @playlist); } sub get_opml { my ( $request_host, $outtype, $modes, $type, $bitrate, $search, $list ) = ( @_ ); my @playlist; $outtype =~ s/^.*\.//g; # # # # Grateful Dead - 1995-07-09-Chicago, IL # # # # # # # print $se "INFO: Getting playlist for type '$type' using modes '$modes', bitrate '$bitrate', search='$search' and list '$list'\n"; # Header push @playlist, "\n"; # Programmes if (! $list) { # Header push @playlist, "\t\n\t\t\n\t"; push @playlist, "\t"; # Extract and rewrite into playlist format my @out = get_cmd_output( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( 'nopurge=1', "type=$type", 'listformat=|||', "search=$search" ), ); for ( grep !/^(Added:|Matches|$)/, @out ) { chomp(); # Strip unprinatble chars s/(.)/(ord($1) > 127) ? "" : $1/egs; my ($pid, $name, $episode, $desc) = (split /\|/)[0,1,2,3]; next if ! ( $pid && $name ); push @playlist, "\t\t"; } # Top-level Menu } elsif ( lc($list) eq 'menu' ) { my %menu = ( 'BBC iPlayer Radio Listen Again'=> "${request_host}?ACTION=opml&PROGTYPES=radio&LIST=channel", ); # Header push @playlist, "\t\n\t\t\n\t"; push @playlist, "\t"; for my $item ( sort keys %menu ) { my $item_url = $menu{ $item }; #http://localhost:1935/opml?PROGTYPES=SEARCH=bbc+radio+1&MODES=${modes}&OUTTYPE=a.wav push @playlist, "\t\t"; } # Channels/Names etc } elsif ($list) { # Header push @playlist, "\t\n\t\t\n\t"; push @playlist, "\t"; # Extract and rewrite into playlist format my @out = get_cmd_output( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( 'nopurge=1', "type=$type", "list=$list", "channel=$search" ), ); for ( grep !/^(Added:|Matches|$)/, @out ) { my $suffix; chomp(); # Strip unprinatble chars s/(.)/(ord($1) > 127) ? "" : $1/egs; next if ! m{^.+\(\d+\)$}; my $item = $_; s/\s*\(\d+\)$//g; my $itemregex = '^'.$_.'$'; # URL encode it $itemregex =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg; # Stateful addition of search terms $suffix = '&LIST=name' if $list eq 'channel'; # Format required, e.g. #http://localhost:1935/opml?PROGTYPES=SEARCH=bbc+radio+1&MODES=${modes}&OUTTYPE=a.wav push @playlist, "\t\t"; } } # Footer push @playlist, "\t\n"; return join ("\n", @playlist); } ### Playlist URL builders sub build_url_direct { my ( $request_host, $progtypes, $pid, $modes, $outtype, $streamtype, $history, $bitrate, $vsize, $vfr, $versionlist ) = ( @_ ); # Sanity check #print $se "DEBUG: building direct playback request using: PROGTYPES=${progtypes} PID=${pid} MODES=${modes} OUTTYPE=${outtype}\n"; # CGI::escape $_ = CGI::escape($_) for ( $progtypes, $pid, $modes, $outtype, $streamtype, $history, $bitrate, $vsize ); #print $se "DEBUG: building direct playback request using: PROGTYPES=${progtypes} PID=${pid} MODES=${modes} OUTTYPE=${outtype} BITRATE=${bitrate} VSIZE=${vsize} VFR=${vfr}\n"; # Build URL return "${request_host}?ACTION=direct&PROGTYPES=${progtypes}&PID=${pid}&MODES=${modes}&HISTORY=${history}&OUTTYPE=${outtype}&STREAMTYPE=${streamtype}&BITRATE=${bitrate}&VSIZE=${vsize}&VFR=${vfr}&VERSIONLIST=${versionlist}"; } # "${request_host}?ACTION=stream&PROGTYPES=${type}&PID=${pid}&MODES=${modes}&OUTTYPE=${suffix}"; sub build_url_stream { my ( $request_host, $progtypes, $pid, $modes, $outtype, $streamtype, $bitrate, $vsize, $vfr, $versionlist ) = ( @_ ); # Sanity check #print $se "DEBUG: building stream playback request using: PROGTYPES=${progtypes} PID=${pid} MODES=${modes} OUTTYPE=${outtype}\n"; # CGI::escape $_ = CGI::escape($_) for ( $progtypes, $pid, $modes, $outtype, $streamtype, $bitrate, $vsize, $vfr ); #print $se "DEBUG: building stream playback request using: PROGTYPES=${progtypes} PID=${pid} MODES=${modes} OUTTYPE=${outtype}\n"; # Build URL return "${request_host}?ACTION=stream&PROGTYPES=${progtypes}&PID=${pid}&MODES=${modes}&OUTTYPE=${outtype}&STREAMTYPE=${streamtype}&BITRATE=${bitrate}&VSIZE=${vsize}&VFR=${vfr}&VERSIONLIST=${versionlist}"; } # Play from Internet/'Play': ?ACTION=playlist &SEARCHFIELDS=pid &SEARCH=$pid &MODES=${modes} &PROGTYPES=${type} &OUTTYPE=${outtype}' ## 'PlayFile' - works with vlc # Play from local file/'PlayFile' ?ACTION=playlistfiles &SEARCHFIELDS=pid &SEARCH=$pid &MODES=${modes} &PROGTYPES=${type} ## 'PlayWeb' - not on vlc # Play from file on web server/'PlayWeb' ?ACTION=playlistdirect &SEARCHFIELDS=pid &SEARCH=$pid &MODES=${modes} sub build_url_playlist { my ( $request_host, $action, $searchfields, $search, $modes, $progtypes, $outtype, $streamtype, $bitrate, $vsize, $vfr, $versionlist ) = ( @_ ); # Sanity check #print $se "DEBUG: building $action request using: SEARCHFIELDS=${searchfields} SEARCH=${search} MODES=${modes} PROGTYPES=${progtypes} OUTTYPE=${outtype}\n"; # CGI::escape $_ = CGI::escape($_) for ( $action, $searchfields, $search, $modes, $progtypes, $outtype, $streamtype, $bitrate, $vsize, $vfr ); #print $se "DEBUG: building $action request using: SEARCHFIELDS=${searchfields} SEARCH=${search} MODES=${modes} PROGTYPES=${progtypes} OUTTYPE=${outtype}\n"; # Build URL return "${request_host}?ACTION=${action}&SEARCHFIELDS=${searchfields}&SEARCH=${search}&MODES=${modes}&PROGTYPES=${progtypes}&OUTTYPE=${outtype}&STREAMTYPE=${streamtype}&BITRATE=${bitrate}&VSIZE=${vsize}&VFR=${vfr}&VERSIONLIST=${versionlist}"; } # Generic # Gets the contents of a URL and retries if it fails, returns '' if no page could be retrieved # Usage = request_url_retry(, , , , []); sub request_url_retry { my %OPTS = @LWP::Protocol::http::EXTRA_SOCK_OPTS; $OPTS{SendTE} = 0; @LWP::Protocol::http::EXTRA_SOCK_OPTS = %OPTS; my ($ua, $url, $retries, $succeedmsg, $failmsg) = @_; my $res; # Malformed URL check if ( $url !~ m{^\s*https?\:\/\/}i ) { print $se "ERROR: Malformed URL: '$url'\n"; return ''; } my $i; print $se "INFO: Getting page $url\n" if $opt->{verbose}; for ($i = 0; $i < $retries; $i++) { $res = $ua->request( HTTP::Request->new( GET => $url ) ); if ( ! $res->is_success ) { print $se $failmsg; } else { print $se $succeedmsg; last; } } # Return empty string if we failed return '' if $i == $retries; return $res->content; } # Invokes command in @args as a system call (hopefully) without using a shell # Can also redirect all stdout and stderr to either: STDOUT, STDERR or unchanged # Usage: run_cmd( <''|STDOUTFH>, <''|STDERRFH>, @args ) # Returns: exit code # Note: doesn't appear to work with 'in memory' filehandles sub run_cmd_unix { # Define what to do with STDOUT and STDERR of the child process my $fh_child_out = shift || "STDOUT"; my $fh_child_err = shift || "STDERR"; my @cmd = ( @_ ); my $rtn; print $se "INFO: Command: ".(join ' ', @cmd)."\n"; # if $opt->{verbose}; # Check if we have IPC::Open3 otherwise fallback on system() eval "use IPC::Open3"; # probably only likely in win32 if ($@) { print $se "ERROR: Please download and run latest installer - 'IPC::Open3' is not available\n"; exit 1; # Use open3() } else { #print $se "INFO: open3( 0, \">&".fileno($fh_child_out).", \">&".fileno($fh_child_err).", )\n"; # Don't use NULL for the 1st arg of open3 otherwise we end up with a messed up STDIN once it returns my $procid = open3( 0, ">&".fileno($fh_child_out), ">&".fileno($fh_child_err), @cmd ); # Wait for child to complete waitpid( $procid, 0 ); $rtn = $?; } # Interpret return code return interpret_return_code( $rtn ); } # Invokes command in @args as a system call (hopefully) without using a shell # Can also redirect all stdout and stderr to either: STDOUT, STDERR or unchanged # Usage: run_cmd( $stdout_fh, $stderr_fh, , @args ) # Returns: exit code sub run_cmd { # win32 kludge cos win is so broken return run_cmd_win32( @_ ) if IS_WIN32; # Define what to do with STDOUT and STDERR of the child process use IO::Select; use Symbol qw(gensym); my $fh_cmd_out = shift; my $fh_cmd_err = shift; my $size = shift; my $from = new IO::Handle; my $err = new IO::Handle; my @cmd = ( @_ ); my $direct = grep(/$opt_cmdline->{ffmpeg}/, @cmd); my $is_hls = grep(/modes%3Dhl(s|x)/, @cmd); my $stdout_raw = $direct; my $rtn; $fh_cmd_out->autoflush(1); $fh_cmd_err->autoflush(1); print $se "INFO: Command: ".(join ' ', @cmd)."\n"; # if $opt->{verbose}; # Check if we have IPC::Open3 otherwise fallback on system() eval "use IPC::Open3"; # probably only likely in win32 if ($@) { print $se "ERROR: Please download and run latest installer - 'IPC::Open3' is not available\n"; exit 1; # Use open3() } else { my $procid; # Setup signal handlers so that when the browser is closed the SIGPIPE results in sending a SIGTERM to the forked command. local $SIG{PIPE} = sub { my $signal = shift; print $se "\nINFO: $$ Cleaning up (signal = $signal), killing cmd PID=$procid:\n"; for my $sig ( qw/INT PIPE TERM KILL/ ) { # Kill process with SIGs print $se "INFO: $$ killing cmd PID=$procid with SIG${sig}\n"; kill $sig, $procid; sleep 1; if ( ! kill 0, $procid ) { print $se "INFO: $$ killed cmd PID=$procid\n"; last; } sleep 4; } exit 0; }; # Don't use NULL for the 1st arg of open3 otherwise we end up with a messed up STDIN once it returns $procid = open3( gensym, $from, $err, @cmd ) || print $se "ERROR: Could not execute command: $!\n"; my $childpidout = fork(); # Fork a child process to read from the indirect (STDOUT) fh of the spawned command and write it to the selected fh (browser client) if ( $childpidout <= 0 ) { # Not sure if these are necessary: $fh_cmd_out->autoflush(1); $from->autoflush(1); if ( $stdout_raw) { binmode $from, ':raw'; } else { binmode $from, ':utf8'; } # Read each char from command output and push to socket fh my $char; my $bytes; while ( $bytes = read( $from, $char, $size ) ) { if ( $bytes <= 0 ) { print $se "DEBUG: STDOUT fd closed - exiting thread\n"; exit 0; } else { print $fh_cmd_out $char; } last if $bytes < $size; } #print $se "CMD STDOUT FH EMPTY\n"; exit 0; # Parent continues here } elsif ( defined $childpidout ) { print $se "DEBUG: Forked STDOUT reader with PID $childpidout\n"; # Failed to fork } else { print $se "ERROR: Failed to fork STDOUT reader process: $!\n"; exit 1; } my $childpiderr = fork(); # Fork a child process to read from the indirect (STDERR) fh of the spawned command and write it to the selected fh (browser client) if ( $childpiderr <= 0 ) { # Not sure if these are necessary: $fh_cmd_err->autoflush(1); $err->autoflush(1); binmode $err, ':utf8'; # Read each char from command output and push to socket fh my $char; my $bytes; # Assume that we don't want to buffer STDERR output of the command $size = 1; if ( $is_hls ) { my ($count, $buf); while ( $bytes = read( $err, $char, $size ) ) { if ( $bytes <= 0 ) { print $se "DEBUG: STDERR fd closed - exiting thread\n"; exit 0; } else { if ( $char eq "#" ) { print $fh_cmd_err $char; } elsif ( $char =~ /[\r\n]/ ) { if ( $buf =~ /size=/ ) { $count++; print $fh_cmd_err "#"; print $fh_cmd_err "\n" if ! ($count % 100); } else { print $fh_cmd_err $buf; print $fh_cmd_err "\n"; } $buf = ''; } else { $buf .= $char; } } if ( $bytes < $size ) { print $fh_cmd_err "$buf\n" if $buf; last; } } } else { while ( $bytes = read( $err, $char, $size ) ) { if ( $bytes <= 0 ) { print $se "DEBUG: STDERR fd closed - exiting thread\n"; exit 0; } else { print $fh_cmd_err $char; } last if $bytes < $size; } } #print $se "CMD STDERR FH EMPTY\n"; exit 0; # Parent continues here } elsif ( defined $childpiderr ) { print $se "DEBUG: Forked STDERR reader with PID $childpiderr\n"; # Failed to fork } else { print $se "ERROR: Failed to fork STDERR reader process: $!\n"; exit 1; } # Reap reader processes waitpid( $childpidout, 0 ); waitpid( $childpiderr, 0 ); # Reap command child waitpid( $procid, 0 ); $rtn = $?; # Restore sigpipe handler for reader and writer processes $SIG{PIPE} = 'DEFAULT'; } # Interpret return code return interpret_return_code( $rtn ); } # Works except for where both from and err go to fh - does not die when browser closes. # Also the browser does not get closed after cmd completes... # Uses shell when stderr needs to be redirected to stdout sub run_cmd_win32 { # Define what to do with STDOUT and STDERR of the child process my $fh_child_out = shift; my $fh_child_err = shift; my $size = shift; my @cmd = ( @_ ); # eek! - works around win32 inability to redirect STDERR nicely # If the stderr is supposed to go to the same fh and stdout then add '2>&1' push @cmd, '2>&1' if fileno($fh_child_out) == fileno($fh_child_err); my $rtn; # Disable buffering $fh_child_out->autoflush(1); print $se "INFO: Win32 Command: ".(join ' ', @cmd)."\n"; # if $opt->{verbose}; # Redirect $fh_child_out to STDOUT open(STDOUT, ">&", $fh_child_out ) || die "can't dup client to stdout"; $rtn = system( @cmd ); # Interpret return code return interpret_return_code( $rtn ); } # PVR Run and Refresh Cache pages will not auto-refresh if client socket # is dup()-ed to STDOUT (as in run_cmd_win32). Run command in shell and # copy get_iplayer output to client socket instead. sub run_cmd_autorefresh { return run_cmd( @_ ) unless IS_WIN32; # Define what to do with STDOUT and STDERR of the child process my $fh_child_out = shift; my $fh_child_err = shift; my $size = shift; my @cmd = ( @_ ); # workaround to add quotes around the args because we are using a shell here for ( @cmd ) { s/^(.+)$/"$1"/g if ! m{^[\-\"]}; } # eek! - works around win32 inability to redirect STDERR nicely # If the stderr is supposed to go to the same fh and stdout then add '2>&1' push @cmd, '2>&1' if fileno($fh_child_out) == fileno($fh_child_err); # Disable buffering $fh_child_out->autoflush(1); print $se "INFO: Win32 Command: ".(join ' ', @cmd)."\n"; # if $opt->{verbose}; my $buf; my $bytes; open( CMD, ( join ' ', @cmd ).'|' ) || die "can't open pipe: $!\n"; binmode CMD, ':utf8'; while ( $bytes = read( CMD, $buf, $size ) ) { if ( $bytes <= 0 ) { print $se "DEBUG: pipe fd closed - exiting thread\n"; exit 0; } else { print $fh_child_out $buf; } last if $bytes < $size; } close(CMD); # Interpret return code return interpret_return_code( $? ); } # Same as backticks but without needing a shell # sets $? # returns array of output sub get_cmd_output { # win32 kludge cos win is so broken return get_cmd_output_win32( @_ ) if IS_WIN32; use Symbol qw(gensym); my @cmd = ( @_ ); #my $to = new IO::Handle; my $from = new IO::Handle; my $error = new IO::Handle; my $rtn; my @out_from; my @out_error; #$to->autoflush(1); $from->autoflush(1); $error->autoflush(1); print $se "INFO: Command: ".(join ' ', @cmd)."\n"; # if $opt->{verbose}; # Check if we have IPC::Open3 otherwise fallback on system() eval "use IPC::Open3"; # probably only likely in win32 if ($@) { print $se "ERROR: Please download and run latest installer - 'IPC::Open3' is not available\n"; exit 1; # Use open3() } else { my $procid; # Setup signal handlers so that when the browser is closed the SIGPIPE results in sending a SIGTERM to the forked command. local $SIG{PIPE} = sub { my $signal = shift; print $se "\nINFO: $$ Cleaning up (signal = $signal), killing cmd PID=$procid:\n"; for my $sig ( qw/INT PIPE TERM KILL/ ) { # Kill process with SIGs print $se "INFO: $$ killing cmd PID=$procid with SIG${sig}\n"; kill $sig, $procid; sleep 1; if ( ! kill 0, $procid ) { print $se "INFO: $$ killed cmd PID=$procid\n"; last; } sleep 4; } exit 0; }; #print $se "INFO: open3( 0, \">&".fileno($fh_child_out).", \">&".fileno($fh_child_err).", )\n"; # Don't use NULL for the 1st arg of open3 otherwise we end up with a messed up STDIN once it returns $procid = open3( gensym, $from, $error, @cmd ); # Wait for child to complete my $childpid = fork(); binmode $se, IS_WIN32 ? ":encoding(cp1252)" : ':encoding(UTF-8)'; # Child if ( $childpid == 0 ) { binmode $error, ':utf8'; while ( <$error> ) { print $se "CMD STDERR: $_"; } #print $se "CMD STDERR EMPTY\n"; exit 0; # Parent } elsif ( defined $childpid ) { binmode $from, ':utf8'; while ( <$from> ) { push @out_from, $_; } } else { print $se "ERROR: Could not fork STDERR reader process\n"; exit 1; } waitpid( $childpid, 0 ); waitpid( $procid, 0 ); $rtn = $?; # Restore sigpipe handler for reader and writer processes $SIG{PIPE} = 'DEFAULT'; } # Interpret return code interpret_return_code( $rtn ); return @out_from; } # Still uses shell sub get_cmd_output_win32 { my ( @cmd ) = ( @_ ); # workaround to add quotes around the args because we are using a shell here for ( @cmd ) { s/^(.+)$/"$1"/g if ! m{^[\-\"]}; } print $se "DEBUG: Command: ".( join ' ', @cmd )."\n"; open( CMD, ( join ' ', @cmd ).'|' ) || print $se "ERROR: echo failed: $!\n"; binmode CMD, ':utf8'; my @out = ; close CMD; # Interpret return code interpret_return_code( $? ); return @out; } sub interpret_return_code { my $rtn = shift; # Interpret return code and force return code 2 upon error my $return = $rtn >> 8; if ( $rtn == -1 && $IGNOREEXIT ) { $return = 0; } elsif ( $rtn == -1 ) { print $se "ERROR: Command failed to execute: $!\n"; $return = 2 if ! $return; } elsif ( $rtn & 128 ) { print $se "WARNING: Command executed but coredumped\n"; $return = 2 if ! $return; } elsif ( $rtn & 127 ) { print $se sprintf "WARNING: Command executed but died with signal %d\n", $rtn & 127; $return = 2 if ! $return; } print $se sprintf "INFO: Command exit code %d\n", $return if $return; return $return; } sub get_pvr_list { my $pvrsearch; my $out = join "\n", get_cmd_output( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--pvrlist', ); # Remove text before first pvrsearch entry $out =~ s/^.+?(pvrsearch\s.+)$/$1/s; # Parse all 'pvrsearch' elements for ( split /pvrsearch\s+\=\s+/, $out ) { next if /^get_iplayer/; my $name; $_ = "pvrsearch = $_"; # Get each element while ( /([\w\-]+?)\s+=\s+(.+?)\n/sg ) { if ( $1 eq 'pvrsearch' ) { $name = $2; } $pvrsearch->{$name}->{$1} = $2; # Remove disabled entries if ( $pvrsearch->{$name}->{disable} == 1 ) { delete $pvrsearch->{$name}; last; } } } return $pvrsearch; } sub show_pvr_list { my %fields; my $pvrsearch = get_pvr_list(); my $sort_field = $cgi->param( 'PVRSORT' ) || 'name'; my $reverse = $cgi->param( 'PVRREVERSE' ) || '0'; # Sort data my @pvrsearches = get_sorted( $pvrsearch, $sort_field, $reverse ); # Parse all 'pvrsearch' elements to get all fields used for my $name ( @pvrsearches ) { # Get each element for ( keys %{ $pvrsearch->{$name} } ) { $fields{$_} = 1; } } # Render options actions my $buttons = div( { -class=>'action' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ a( { -class=>'action', -title => 'Go Back', -onClick => "history.back()", }, 'Back' ), a( { -class => 'action', -title => 'Delete selected programmes from PVR search list', -onClick => "if(! check_if_selected(document.form1, 'PVRSELECT')) { alert('No programmes were selected'); return false; } BackupFormVars(form1); form1.NEXTPAGE.value='pvr_del'; form1.submit(); RestoreFormVars(form1);", }, 'Delete' ), ]), ), ); my @html; my @displaycols = ( 'pvrsearch', ( grep !/pvrsearch/, ( sort keys %fields ) ) ); # Build header row push @html, ""; push @html, th( { -class => 'search' }, checkbox( -class=>'search', -title=>'Select/Unselect All PVR Searches', -onClick=>"check_toggle(document.form1, 'PVRSELECT')", -name=>'SELECTOR', -value=>'1', -label=>'' ) ); # Display data in nested table for my $heading (@displaycols) { # Sort by column click and change display class (colour) according to sort status my ($title, $class, $onclick); if ( $sort_field eq $heading && not $reverse ) { ($title, $class, $onclick) = ("Sort by Reverse $fieldname{$heading}", 'sorted pointer', "BackupFormVars(form1); form1.NEXTPAGE.value='pvr_list'; form1.PVRSORT.value='$heading'; form1.PVRREVERSE.value=1; form1.submit(); RestoreFormVars(form1);"); } else { ($title, $class, $onclick) = ("Sort by $fieldname{$heading}", 'unsorted pointer', "BackupFormVars(form1); form1.NEXTPAGE.value='pvr_list'; form1.PVRSORT.value='$heading'; form1.submit(); RestoreFormVars(form1); "); } $class = 'sorted_reverse pointer' if $sort_field eq $heading && $reverse; push @html, th( { -class => 'search' }, label( { -title => $title, -class => $class, -onClick => $onclick, }, $fieldname{$heading} || $heading, ) ); } push @html, ""; # Build each row for my $name ( @pvrsearches ) { my @row; push @row, td( {-class=>'search'}, checkbox( -class => 'search', -name => 'PVRSELECT', -label => '', -value => "$name", -checked => 0, -override => 1, ) ); for ( @displaycols ) { push @row, td( {-class=>'search'}, label( { -title => "Click to Edit", -class => 'search', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='pvr_edit'; form1.PVRSEARCH.value='$name'; form1.submit(); RestoreFormVars(form1);", }, $pvrsearch->{$name}->{$_}, ) ); } push @html, Tr( {-class=>'search'}, @row ); } # Search form print $fh start_form( -name => "form1", -method => "POST", ); print $fh p("Click to Edit any PVR Search"); # Render options actions print $fh $buttons; # Render table print $fh table( {-class=>'search'} , @html ); print $fh $buttons; # Make sure we go to the correct nextpage for processing print $fh hidden( -name => "NEXTPAGE", -value => "pvr_list", -override => 1, ); # Reverse sort value print $fh hidden( -name => "PVRREVERSE", -value => 0, -override => 1, ); print $fh hidden( -name => "PVRSORT", -value => $sort_field, -override => 1, ); print $fh hidden( -name => "PVRSEARCH", -value => '', -override => 1, ); print $fh end_form(); return 0; } # Edits a single record indicated by PVRSELECT sub pvr_edit { my %fields; my $pvrsearch = get_pvr_list(); my @html; my $pvrname = $cgi->param( 'PVRSEARCH' ); # Determine max field length my $maxwidth = 30; for ( values %{ $pvrsearch->{$pvrname} } ) { $maxwidth = length($_) if length($_) > $maxwidth && $maxwidth < 200; } # Get each element for my $key ( keys %{ $pvrsearch->{$pvrname} } ) { my $val = $pvrsearch->{$pvrname}->{$key}; # Put INPUT field here my $element; #if ( $key eq 'pvrsearch' ) { # $element = $val; #} else { $element = hidden( -name => "EDITKEYS", -value => $key, -override => 1, ). textfield( -class => 'edit', -name => "EDITVALUES", -value => $val, -size => $maxwidth + 20, ); #} push @html, Tr( { -class => 'info' }, th( { -class => 'info' }, $key ).td( { -class => 'info' }, $element ) ); } # Editing form print $fh start_form( -name => "form1", -method => "POST", ); print $fh table( { -class => 'info' }, @html ); # Render options actions print $fh div( { -class=>'action' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ a( { -class=>'action', -title => 'Go Back', -onClick => "history.back()", }, 'Back' ), a( { -class => 'action', -title => 'Save changes', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='pvr_save'; form1.submit(); RestoreFormVars(form1);", }, 'Save Changes' ), ]), ), ); # Make sure we go to the correct nextpage for processing print $fh hidden( -name => "NEXTPAGE", -value => "pvr_add", -override => 1, ); print $fh hidden( -name => "PVRSEARCH", -value => $pvrname, -override => 1, ); print $fh end_form(); return 0; } # # Will return a list of pids sorted by the requested Heading # sub get_sorted { my @sorted; my @unsorted; my $data = shift; my $sort_field = shift; my $reverse = shift; # Lookup table for nice field name headings my %sorttype = ( index => 'numeric', duration => 'numeric', timeadded => 'numeric', seriesnum => 'numeric', episodenum => 'numeric', expires => 'numeric', ); # Insert search '~~~' for each prog in hash for my $key (keys %{ $data } ) { # generate sort column push @unsorted, $data->{$key}->{$sort_field}.'~~~'.$key; } # If this a purely numerical field if ( defined $sorttype{$sort_field} && $sorttype{$sort_field} eq 'numeric' ) { if ($reverse) { @sorted = reverse sort {$a <=> $b} @unsorted; } else { @sorted = sort {$a <=> $b} @unsorted; } # otherwise sort alphabetically } else { if ($reverse) { @sorted = reverse sort { lc $a cmp lc $b } @unsorted; } else { @sorted = sort { lc $a cmp lc $b } @unsorted; } } # Strip off seach key at beginning of each line s/^.*~~~// for @sorted; return @sorted; } sub pvr_del { my @record = ( $cgi->param( 'PVRSELECT' ) ); my $out; # Queue all selected '|' entries in the PVR for my $name (@record) { chomp(); my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( "pvrdel=$name" ), ); print $fh p("Command: ".( join ' ', @cmd ) ) if $opt_cmdline->{debug}; my $cmdout = join "", get_cmd_output( @cmd ); return p("ERROR: ".$out) if $? && not $IGNOREEXIT; print $fh p("Deleted: $name"); $out .= $cmdout; } print $fh "
$out
"; # Show list below show_pvr_list(); return $out; } sub show_info { my $progdata = ( $cgi->param( 'INFO' ) ); my $out; my @html; my %prog; my ( $type, $pid ) = split /\|/, $progdata; # Queue all selected '|' entries in the PVR chomp(); my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( 'nopurge=1', "type=$type", "future=$opt->{FUTURE}->{current}", "history=$opt->{HISTORY}->{current}", "skipdeleted=$opt->{HIDEDELETED}->{current}", 'info=1', 'fields=pid', "search=$pid" ), ); print $fh p("Command: ".( join ' ', @cmd ) ) if $opt_cmdline->{debug}; my @cmdout = get_cmd_output( @cmd ); return p("ERROR: ".@cmdout) if $? && not $IGNOREEXIT; for ( grep !/^(Added|INFO):/, @cmdout ) { my ( $key, $val ) = ( $1, $2 ) if m{^(\w+?):\s*(.+?)\s*$}; next if $key =~ /(^$|^\d+$)/ || $val =~ /Matching Program/i; $out .= "$key: $val\n"; $prog{$pid}->{$key} = $val; # Make into a link if this value is a URL $val = a( { -class=>'info', -title=>'Open URL', -href=>$val }, $val ) if $val =~ m{^http://.+}; push @html, Tr( { -class => 'info' }, th( { -class => 'info' }, $key ).td( { -class => 'info' }, $val ) ); } # Show thumb if one exists print $fh img( { -class=>'action', -src=>$prog{$pid}->{thumbnail} } ) if $prog{$pid}->{thumbnail}; # Set optional output dir for pvr queue if set my $outdir; $outdir = '&OUTPUT='.CGI::escape("$opt->{OUTPUT}->{current}") if $opt->{OUTPUT}->{current}; # Render options actions print $fh div( { -class=>'action' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ a( { -class=>'action', -title => 'Close', -onClick => "window.close()", }, 'Close' ), ]), ), ); print $fh table( { -class => 'info' }, @html ); return $out; } # Get filename from history based on PID, MODE and TYPE # If the PID is a filename then filename is still searched using PID and TYPE sub get_direct_filename { my ( $pid, $mode, $type ) = ( @_ ); my $out; my @html; my %prog; my $pidisfile; my $history = 1; print $se "DEBUG: Looking up filename for MODE=$mode TYPE=$type PID=$pid\n"; # set this flag if required and unset history if pid is a file if ( -f $pid ) { print $se "DEBUG: PID is a valid filename\n"; $pidisfile = 1; $history = 0; } # Skip if not defined or, if pid is a file and no type defined if ( $pidisfile && ! $type ) { print $se "ERROR: Cannot lookup filename for PID which is a filename if type is not set\n"; return ''; } if ( ( ! $pidisfile ) && ! ( $pid && $mode && $type ) ) { print $se "ERROR: Cannot lookup filename unless PID, MODE and TYPE are set\n"; return ''; } # make the pid regex friendly $pid =~ s|([\/\.\?\+\-\*\^\(\)\[\]\{\}])|\\$1|g; # Get the 'filename' entry from --history --info for this pid my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( 'nopurge=1', "history=$history", 'fields=pid', "search=$pid", "type=$type", 'listformat=filename: ||' ), ); print $se "Command: ".( join ' ', @cmd )."\n"; # if $opt_cmdline->{debug}; my @cmdout = get_cmd_output( @cmd ); return p("ERROR: ".@cmdout) if $? && not $IGNOREEXIT; # Extract the filename my $match = ( grep /^filename:/, @cmdout )[0]; my $filename; if ( $pidisfile ) { $filename = $1 if $match =~ m{^filename: (\/.+?)\|\|\s*$}; } else { $filename = $1 if $match =~ m{^filename: .+?\|\s*(.+?)\|$mode\s*$}; } if ( $filename && $opt_cmdline->{encodinglocalefs} !~ /UTF-?8/i ) { $filename = encode($opt_cmdline->{encodinglocalefs}, $filename, sub { '' }); } return search_absolute_path( $filename ); } # Hack to work around relative paths in recordings history sub search_absolute_path { my $filename = shift; my $abs_path; # win32 doesn't seem to like abs_path # abs_path croaks on cygwin if file not found # rewrite win32 paths if ( IS_WIN32 || $^O eq "cygwin" ) { # add a hardcoded prefix for now if relative path (assume relative to local get_iplayer script) if ( $filename !~ m{^[A-Za-z]:} && $filename =~ m{^(\.|\.\.|[A-Za-z_])} ) { $filename = dirname( abs_path( $opt_cmdline->{getiplayer} ) ).'/'.$filename; } if ( IS_WIN32 ) { # twiddle the / to \ $filename =~ s!(\\/|/|\/)!\\!g; } return $filename; } #print $se "FILENAME='$filename'"; # Try using CWD if ( -f abs_path($filename) ) { $abs_path = abs_path($filename); # repair abs_path decomposition of UTF-8 filename if ( $abs_path && $opt_cmdline->{encodinglocalefs} =~ /UTF-?8/i ) { $abs_path = decode($opt_cmdline->{encodinglocalefs}, $abs_path, sub { '' }); } # else try dir of get_iplayer } elsif ( -f dirname( abs_path( $opt_cmdline->{getiplayer} ) ).'/'.$filename ) { $abs_path = dirname( abs_path( $opt_cmdline->{getiplayer} ) ).'/'.$filename; # else try dir current output dir option } elsif ( $opt->{OUTPUT}->{current} && -f abs_path( $opt->{OUTPUT}->{current} ).'/'.$filename ) { $abs_path = abs_path( $opt->{OUTPUT}->{current} ).'/'.$filename; # Else just return the relative path } else { $abs_path = $filename; } #print $se " -> ABSPATH='$abs_path'\n"; return $abs_path; } sub pvr_queue { # Gets the multiple selections of progs to queue from PROGSELECT my @record; # The 'Record' action button uses SEARCH to pass it's pvr_queue data if ( $cgi->param( 'SEARCH' ) ) { push @record, $cgi->param( 'SEARCH' ); } else { @record = ( $cgi->param( 'PROGSELECT' ) ); } my @params = get_search_params(); my $out; # If a URL was specified by the User (assume auto mode list is OK): if ( $opt->{URL}->{current} =~ m{^http://} ) { push @record, "$opt->{PROGTYPES}->{current}|$opt->{URL}->{current}|$opt->{URL}->{current}|-"; } print $fh "

Queuing The Following Programmes in the PVR

    \n"; for (@record) { chomp(); my ( $type, $pid, $name, $episode ) = (split /\|/)[0,1,2,3]; next if ! ($type && $pid ); print $fh "
  • $name - $episode ($pid)
  • \n"; } print $fh "

\n"; # Queue all selected 'TYPE|PID|NAME|EPISODE|MODE|CHANNEL' entries in the PVR for (@record) { chomp(); my ( $type, $pid, $name, $episode ) = (split /\|/)[0,1,2,3]; next if ! ($type && $pid ); my $comment = "$name - $episode"; $comment =~ s/\'\"//g; $comment =~ s/[^\s\w\d\-:\(\)]/_/g; $comment =~ s/^_*//g; $comment =~ s/_*$//g; my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( 'pvrqueue=1', "pid=$pid", "comment=$comment (queued: ".localtime().')', "type=$type", build_cmd_options( grep !/^(HISTORY|SINCE|BEFORE|HIDEDELETED|FUTURE|SEARCH|SEARCHFIELDS|PROGTYPES|EXCLUDEC.+)$/, @params ) ), ); print $fh p("Command: ".( join ' ', @cmd ) ) if $opt_cmdline->{debug}; my $cmdout = join "", get_cmd_output( @cmd ); return p("ERROR: ".$out) if $? && not $IGNOREEXIT; print $fh p("Queued: $type: '$name - $episode' ($pid)"); $out .= $cmdout; } print $fh "
$out
"; # Show list below show_pvr_list(); return $out; } sub recordings_delete { # Gets the multiple selections of progs to queue from PROGSELECT my @record; # The 'Record' action button uses SEARCH to pass it's pvr_queue data if ( $cgi->param( 'SEARCH' ) ) { push @record, $cgi->param( 'SEARCH' ); } else { @record = ( $cgi->param( 'PROGSELECT' ) ); } my @params = get_search_params(); # Render options actions my $buttons = div( { -class=>'action' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ a( { -class=>'action', -title => 'Go Back', -onClick => "history.back()", }, 'Back' ), ]), ), ); # Render options actions print $fh $buttons; print $fh "

Deleting the Following Programmes:

    \n"; for (@record) { chomp(); my ( $type, $pid, $name, $episode ) = (split /\|/)[0,1,2,3]; next if ! ($type && $pid ); print $fh "
  • $name - $episode ($pid)
  • \n"; } print $fh "

\n"; # Queue all selected 'TYPE|PID|NAME|EPISODE|MODE|CHANNEL' entries in the PVR for (@record) { chomp(); my ( $type, $pid, $name, $episode, $mode ) = (split /\|/)[0,1,2,3,4]; next if ! ($mode && $pid ); my $filename = get_direct_filename( $pid, $mode, $type ); my $dir = dirname( $filename ); my $fileregex = basename( $filename ); # get the filename less the ext $fileregex =~ s/\.\w+$//g; # escape regex metachars $fileregex =~ s/([\\\^\$\.\|\?\*\+\(\)\[\]])/\\$1/g; $fileregex .= '\.\w+$'; # Find matching files .* my $deleted; if ( opendir DIR, $dir ) { for my $file ( grep { /$fileregex/ } readdir(DIR) ) { # Use absolute path $file = "${dir}/${file}"; if ( -f $file ) { if ( ! unlink( $file ) ) { print $fh p("ERROR: Failed to delete $file"); } else { $deleted = 1; print $fh p("Successfully deleted: $type: '$name - $episode', MODE: $mode, PID: $pid"); } } else { print $fh p("ERROR: File does not exist for: $type: '$name - $episode', MODE: $mode, PID: $pid, FILENAME: $filename"); } } if ( ! $deleted ) { print $fh p("No files deleted: $type: '$name - $episode', MODE: $mode, PID: $pid"); } closedir(DIR); } else { print $fh p("ERROR: Cannot open dir '$dir' for file deletion\n"); } } # Render options actions print $fh $buttons; return ''; } sub build_cmd_options { my @options; for ( @_ ) { # skip non-options next if $opt->{$_}->{optkey} eq '' || not defined $opt->{$_}->{optkey} || not $opt->{$_}->{optkey}; my $value = $opt->{$_}->{current}; push @options, "$opt->{$_}->{optkey}=$value" if $value ne ''; } return @options; } sub get_search_params { my @params; for ( keys %{ $opt } ) { # skip non-options next if $opt->{$_}->{optkey} eq '' || not defined $opt->{$_}->{optkey} || not $opt->{$_}->{optkey}; next if grep /^$_$/, @nosearch_params; push @params, $_; } return @params; } # Return get_iplayer command options when supplied an array of = options sub get_iplayer_webrequest_args { my @cmdopts; print $se 'DEBUG: get_iplayer options: "'.join('" "', @_)."\"\n"; for (@_) { push @cmdopts, CGI::escape($_); } my $cmdline = join('?', @cmdopts); return $cmdline; } sub pvr_add { my $out; my @params = get_search_params(); # Only allow alphanumerics,_,-,. here for security reasons my $searchname = "$opt->{SEARCH}->{current}_$opt->{SEARCHFIELDS}->{current}_$opt->{PROGTYPES}->{current}"; $searchname =~ s/[^\w\-\. \+\(\)]/_/g; # Remove a few options from leaking into a PVR search my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( "pvradd=$searchname", build_cmd_options( grep !/^(HISTORY|HIDEDELETED|SINCE|BEFORE|HIDE|FORCE|FUTURE)$/, @params ) ), ); print $se "DEBUG: Command: ".( join ' ', @cmd )."\n"; print $fh p("Command: ".( join ' ', @cmd ) ) if $opt_cmdline->{debug}; $out = join "", get_cmd_output( @cmd ); return p("ERROR: ".$out) if $? && not $IGNOREEXIT; print $fh p("Added PVR Search ($searchname):\n\tTypes: $opt->{PROGTYPES}->{current}\n\tSearch: $opt->{SEARCH}->{current}\n\tSearch Fields: $opt->{SEARCHFIELDS}->{current}\n"); print $fh "
$out
"; # Show list below show_pvr_list(); return $out; } # Delete then add again - just in case user has edited name of pvr search sub pvr_save { my $out; my @keys = $cgi->param( 'EDITKEYS' ); my @values = $cgi->param( 'EDITVALUES' ); my @params; my @search_args; my $newsearchname; # Convert the two keys and values arrays into a KEY=VALUE params array for ( @keys ) { my $val = shift @values; if ( $_ eq 'pvrsearch' ) { $newsearchname = $val; # append search terms to cmdline } elsif ( /^search\d+$/ && $val !~ /^\-/ ) { push @search_args, $val; } else { push @params, $_.'='.$val; } } #print STDERR "ELEMENTS for save: ".(join ',', @params)."\n\n"; # Sanity check if ( $newsearchname eq '' ) { print $fh p("No PVR Search Name Specified - not updated"); return; } # Delete the original pvr entry my $searchname = $cgi->param( 'PVRSEARCH' ); my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( "pvrdel=$searchname" ), ); print $fh p("Command: ".( join ' ', @cmd ) ) if $opt_cmdline->{debug}; my $cmdout = join "", get_cmd_output( @cmd ); return p("ERROR: ".$out) if $? && not $IGNOREEXIT; print $fh p("Deleted: $searchname"); $out .= $cmdout; # Add the new pvr entry @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( "pvradd=$newsearchname", @params ), '--', @search_args, ); print $se "DEBUG: Command: ".( join ' ', @cmd )."\n"; print $fh p("Command: ".( join ' ', @cmd ) ) if $opt_cmdline->{debug}; $out = join "", get_cmd_output( @cmd ); return p("ERROR: ".$out) if $? && not $IGNOREEXIT; print $fh p("Added Updated PVR Search '$newsearchname'\n"); print $fh "
$out
"; # Show list below show_pvr_list(); return $out; } # Build templated HTML for an option specified by passed hashref sub build_option_html { my $arg = shift; my $title = $arg->{title}; my $tooltip = $arg->{tooltip}; my $webvar = $arg->{webvar}; my $option = $arg->{option}; my $type = $arg->{type}; my $label = $arg->{label}; my $current = $arg->{current}; my $value = $arg->{value}; my $status = $arg->{status}; my @html; # On/Off if ( $type eq 'hidden' ) { push @html, hidden( -name => $webvar, -id => "option_$webvar", #-value => $arg->{default}, -value => $current, -override => 1, ); # On/Off } elsif ( $type eq 'boolean' ) { push @html, th( { -class => 'options', -title => $tooltip, -id => "label_option_$webvar" }, $title ). td( { -class => 'options', -title => $tooltip }, checkbox( -class => 'options', -name => $webvar, -id => "option_$webvar", -label => '', #-value => 1, -checked => $current, -override => 1, "aria-labelledby" => "label_option_$webvar", ) ); # On/Off } elsif ( $type eq 'radioboolean' ) { push @html, th( { -class => 'options', -title => $tooltip }, $title ). td( { -class => 'options', -title => $tooltip }, radio_group( -class => 'options', -name => $webvar, -values => [ 0 , 1 ], -labels => { 0=>'Off' , 1=>'On' }, -default => $current, -override => 1, ) ); # Multi-On/Off } elsif ( $type eq 'multiboolean' ) { my $element; # values in hash of $value->{} => value # labels in hash of $label->{$value} # selected status in $status->{$value} my @keylist = sort { $a <=> $b } keys %{ $value }; my $count = 0; while ( @keylist ) { my $val = $value->{shift @keylist}; $element .= td( { -class => 'options' }, table ( { -class => 'options_embedded', -title => $tooltip, -role=>'presentation' }, Tr( { -class => 'options_embedded' }, td( { -class => 'options_embedded' }, [ checkbox( -class => 'options', -name => $webvar, -id => "option_${webvar}_$val", -label => '', -value => $val, -checked => $status->{$val}, -override => 1, "aria-labelledby" => "label_option_${webvar}_$val", ), span({ -id=> "label_option_${webvar}_$val" }, $label->{$val}) ] ) ) ) ); # Spread over more rows if there are many elements if ( not ( ($count+1) % 3 ) ) { $element .= ''; } $count++; } my $inner_table = table ( { -class => 'options_embedded' }, Tr( { -class => 'options_embedded' }, $element ) ); push @html, th( { -class => 'options', -title => $tooltip }, $title ).td( { -class => 'options' }, $inner_table ); # Popup type } elsif ( $type eq 'popup' ) { my @value = $arg->{value}; push @html, th( { -class => 'options', -title => $tooltip, -id => "label_option_$webvar" }, $title ). td( { -class => 'options', -title => $tooltip }, popup_menu( -class => 'options', -name => $webvar, -id => "option_$webvar", -values => @value, -labels => $label, -default => $current, -onChange => $arg->{onChange}, "aria-labelledby" => "label_option_$webvar", ) ); # text field } elsif ( $type eq 'text' ) { push @html, th( { -class => 'options', -title => $tooltip, -id => "label_option_$webvar" }, $title ). td( { -class => 'options', -title => $tooltip }, textfield( -class => 'options', -name => $webvar, -value => $current, -size => $value, -onKeyDown => 'return submitonEnter(event);', "aria-labelledby" => "label_option_$webvar", ) ); } return @html; } sub refresh { my $typelist = join(",", $cgi->param( 'PROGTYPES' )) || 'tv'; my $refreshfuture = $cgi->param( 'REFRESHFUTURE' ) || 0; print $fh "

The cache will auto-refresh every $opt->{AUTOWEBREFRESH}->{current} hour(s) if you leave this page open

" if $opt->{AUTOWEBREFRESH}->{current}; if ( IS_WIN32 ) { print $fh "

Windows users: You may encounter errors if you perform other tasks in the Web PVR Manager while this page is reloading

" if $opt->{AUTOWEBREFRESH}->{current}; } print $se "INFO: Refreshing\n"; my @cmd = ( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--webrequest', get_iplayer_webrequest_args( 'expiry=30', 'nopurge=1', "type=$typelist", "refreshfuture=$refreshfuture", "search=no search just refresh" ), ); print $fh '
';
	run_cmd_autorefresh( $fh, $se, 1, @cmd );
	print $fh '
'; print $fh p("Flushed Programme Caches for Types: $typelist"); # Load the refresh tab if required my $autorefresh = $cgi->cookie( 'AUTOWEBREFRESH' ) || $cgi->param( 'AUTOWEBREFRESH' ); # Render options actions print $fh div( { -class=>'action' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ a( { -class=>'action', -title => 'Refresh Cache Now', -onClick => "RefreshTab( '?NEXTPAGE=refresh&PROGTYPES=$typelist&AUTOWEBREFRESH=$autorefresh', ".(1000*3600*$autorefresh).", 1 );", }, 'Force Refresh' ), a( { -class=>'action', -title => 'Go Back', -onClick => "window.close()", }, 'Close' ), ]), ), ); } # Just a wrapper to search_progs which defines history search settings for 'Recordings' tab sub search_history { $opt->{HISTORY}->{current} = 1; $opt->{SORT}->{current} = 'timeadded'; $opt->{REVERSE}->{current} = 1; $opt->{SINCE}->{current} = ''; $opt->{BEFORE}->{current} = ''; $opt->{EXCLUDE}->{current} = ''; $opt->{CATEGORY}->{current} = ''; $opt->{EXCLUDECATEGORY}->{current} = ''; $opt->{CHANNEL}->{current} = ''; $opt->{EXCLUDECHANNEL}->{current} = ''; search_progs(); } sub search_progs { # Set default status for progtypes my %type; $type{$_} = 1 for split /,/, $opt->{PROGTYPES}->{current}; $opt->{PROGTYPES}->{status} = \%type; # Determine which cols to display and Set default status for cols get_display_cols(); #for my $key (sort keys %ENV) { # print $fh $key, " = ", $ENV{$key}, "\n
"; #} # Get prog data my @params = get_search_params(); my ( $matchcount, $response ) = ( get_progs( @params ) ); if ( $response ) { print $fh p("ERROR: get_iplayer returned non-zero:").br().p( join '
', $response ); return 1; } my ($first, $last, @pagetrail) = pagetrail( $opt->{PAGENO}->{current}, $opt->{PAGESIZE}->{current}, $matchcount, 7 ); # Default displaycols my @html; push @html, ""; push @html, th( { -class => 'search' }, checkbox( -class=>'search', -title=>'Select/Unselect All Programmes', -onClick=>"check_toggle(document.form1, 'PROGSELECT')", -name=>'SELECTOR', -value=>'1', -label=>'' ) ); # Pad empty column for R/S push @html, th( { -class => 'search' }, 'Actions' ); # Display data in nested table for my $heading (@displaycols) { # Sort by column click and change display class (colour) according to sort status my ($title, $class, $onclick); if ( $opt->{SORT}->{current} eq $heading && not $opt->{REVERSE}->{current} ) { ($title, $class, $onclick) = ("Sort by Reverse $heading", 'sorted pointer', "form1.NEXTPAGE.value='search_progs'; form1.SORT.value='$heading'; form1.REVERSE[0].checked=true; form1.submit();"); } else { ($title, $class, $onclick) = ("Sort by $heading", 'unsorted pointer', "form1.NEXTPAGE.value='search_progs'; form1.SORT.value='$heading'; form1.REVERSE[1].checked=true; form1.submit();"); } $class = 'sorted_reverse pointer' if $opt->{SORT}->{current} eq $heading && $opt->{REVERSE}->{current}; push @html, th( { -class => 'search' }, table( { -class => 'searchhead', -role=>'presentation' }, Tr( { -class => 'search' }, [ th( { -class => 'search' }, label( { -title => $title, -class => $class, -onClick => $onclick, }, $fieldname{$heading}, ) ) ] ) ) ); } push @html, ""; # Set optional output dir for pvr queue if set my $outdir; $outdir = '&OUTPUT='.CGI::escape("$opt->{OUTPUT}->{current}") if $opt->{OUTPUT}->{current}; # Build each prog row my $time = time(); for ( my $i = 0; $i <= $#pids; $i++ ) { my $search_class = 'search'; my $pid = $pids[$i]; my @row; # Grey-out history lines which files have been deleted or where the history doesn't have a filename mentioned if ( $opt->{HISTORY}->{current} && ! $opt->{HIDEDELETED}->{current} ) { if ( $prog{$pid}->{filename} && $opt_cmdline->{encodinglocalefs} !~ /UTF-?8/i ) { $prog{$pid}->{filename} = encode($opt_cmdline->{encodinglocalefs}, $prog{$pid}->{filename}, sub { '' }); } if ( ( ! $prog{$pid}->{filename} ) || ! -f $prog{$pid}->{filename} ) { $search_class = 'search darker'; } } # Format of PROGSELECT: TYPE|PID|NAME|EPISODE|MODE|CHANNEL push @row, td( {-class=>$search_class}, checkbox( -class => $search_class, -name => 'PROGSELECT', -label => '', -value => "$prog{$pid}->{type}|$pid|$prog{$pid}->{name}|$prog{$pid}->{episode}|$prog{$pid}->{mode}|$prog{$pid}->{channel}", -checked => 0, -override => 1, ) ); # Record and stream links my $links; # 'Play' # Search mode with filename as pid if ( $pid =~ m{^/} ) { if ( -f $pid ) { # Play $links .= a( { -class=>$search_class, -title=>"Play from file on web server", -href=>build_url_playlist( '', 'playlist', 'pid', $pid, $opt->{MODES}->{current} || $default_modes, $prog{$pid}->{type}, basename( $pid ) , $opt->{STREAMTYPE}->{current}, $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ) }, 'Play' ).'
'; # PlayFile $links .= a( { -id=>'nowrap', -class=>$search_class, -title=>"Play from local file", -href=>build_url_playlist( '', 'playlistfiles', 'pid', $pid, $prog{$pid}->{mode}, $prog{$pid}->{type}, undef, undef ) }, 'Play File' ).'
'; # PlayDirect $links .= a( { -id=>'nowrap', -class=>$search_class, -title=>"Stream file into browser", -href=>build_url_direct( '', $prog{$pid}->{type}, $pid, $prog{$pid}->{mode}, $opt->{STREAMTYPE}->{current}, $opt->{STREAMTYPE}->{current}, $opt->{HISTORY}->{current}, $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ) }, 'Play Direct' ).'
'; } # History mode } elsif ( $opt->{HISTORY}->{current} ) { if ( $opt->{HIDEDELETED}->{current} || -f $prog{$pid}->{filename} ) { # Play (Play Remote) $links .= a( { -id=>'nowrap', -class=>$search_class, -title=>"Play from file on web server", -href=>build_url_playlist( '', 'playlistdirect', 'pid', $pid, $prog{$pid}->{mode}, $prog{$pid}->{type}, 'flv', 'flv', $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ) }, 'Play' ).'
'; # PlayFile $links .= a( { -id=>'nowrap', -class=>$search_class, -title=>"Play from local file", -href=>build_url_playlist( '', 'playlistfiles', 'pid', $pid, $prog{$pid}->{mode}, $prog{$pid}->{type}, undef ) }, 'Play File' ).'
'; # PlayDirect - depends on browser support $links .= a( { -id=>'nowrap', -class=>$search_class, -title=>"Stream file into browser", -href=>build_url_direct( '', $prog{$pid}->{type}, $pid, $prog{$pid}->{mode}, $opt->{STREAMTYPE}->{current}, $opt->{STREAMTYPE}->{current}, $opt->{HISTORY}->{current}, $opt->{BITRATE}->{current}, $opt->{VSIZE}->{current}, $opt->{VFR}->{current}, $opt->{VERSIONLIST}->{current} ) }, 'Play Direct' ).'
'; } # Search mode } else { # Record $links .= label( { -id=>'nowrap', -class=>$search_class, -title=>"Record '$prog{$pid}->{name} - $prog{$pid}->{episode}' Now", -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='record_now'; form1.SEARCH.value='".encode_entities("$prog{$pid}->{type}|$pid|$prog{$pid}->{name}|$prog{$pid}->{episode}|$prog{$pid}->{mode}")."'; form1.target='_newtab_$pid'; form1.submit(); RestoreFormVars(form1); form1.target='';" }, 'Record' ).'
'; # Queue $links .= label( { -id=>'nowrap', -class=>$search_class, -title=>"Queue '$prog{$pid}->{name} - $prog{$pid}->{episode}' for PVR Recording", -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='pvr_queue'; form1.SEARCH.value='".encode_entities("$prog{$pid}->{type}|$pid|$prog{$pid}->{name}|$prog{$pid}->{episode}|$prog{$pid}->{mode}")."'; form1.submit(); RestoreFormVars(form1);" }, 'Queue' ).'
'; # Add Series # escape regex metacharacters in programme name (my $escaped_name = $prog{$pid}->{name}) =~ s/([\\\^\$\.\|\?\*\+\(\)\[\]])/\\\\$1/g; $links .= label( { -id=>'nowrap', -class=>'search pointer_noul', -title=>"Add Series '$prog{$pid}->{name}' to PVR", -onClick=>"BackupFormVars(form1); form1.NEXTPAGE.value='pvr_add'; form1.SEARCH.value='".encode_entities("^$escaped_name\$")."'; form1.SEARCHFIELDS.value='name'; form1.PROGTYPES.value='$prog{$pid}->{type}'; form1.HISTORY.value='0'; form1.SINCE.value=''; form1.BEFORE.value=''; form1.submit(); RestoreFormVars(form1);" }, 'Add Series' ); } # Add links to row push @row, td( {-class=>$search_class}, $links ); # This builds each row in turn for ( @displaycols ) { # display thumb if defined (will have to use proxy to get file:// thumbs) if ( /^thumbnail$/ ) { # Assume a thumbnail prefix if one is missing for BBC iPlayer if ( ! $prog{$pid}->{$_} && $pid =~ m{^[wpb]0[a-z0-9]{6}$} && $prog{$pid}->{type} =~ /^(tv|radio)$/ ) { $prog{$pid}->{$_} = "http://www.bbc.co.uk/iplayer/images/episode/${pid}_150_84.jpg"; } if ( $prog{$pid}->{$_} =~ m{^http://} ) { push @row, td( {-class=>$search_class}, a( { -title=>"Open original web URL", -class=>$search_class, -href=>$prog{$pid}->{web} }, img( { -class=>$search_class, -height=>40, -src=>$prog{$pid}->{$_} } ) ) ); } else { push @row, td( {-class=>$search_class}, a( { -title=>"Open original web URL", -class=>$search_class, -href=>$prog{$pid}->{web} }, 'Open URL' ) ); } # Calculate the seconds difference between epoch_now and epoch_datestring and convert back into array_time } elsif ( /^timeadded$/ ) { my @t = gmtime( $time - $prog{$pid}->{$_} ); my $years = ($t[5]-70)."y " if ($t[5]-70) > 0; push @row, td( {-class=>$search_class}, label( { -class=>$search_class, -title=>"Click for full info", -onClick=>"BackupFormVars(form1); form1.NEXTPAGE.value='show_info'; form1.INFO.value='".encode_entities("$prog{$pid}->{type}|$pid")."'; form1.target='_blank'; form1.submit(); RestoreFormVars(form1); form1.target='';" }, "${years}$t[7]d $t[2]h ago" ) ); } elsif ( /^expires$/ ) { my $expires; if ( $prog{$pid}->{$_} && $prog{$pid}->{$_} > $time ) { my @t = gmtime( $prog{$pid}->{$_} - $time ); my $years = ($t[5]-70)."y " if ($t[5]-70) > 0; $expires = "in ${years}$t[7]d $t[2]h"; } push @row, td( {-class=>$search_class}, label( { -class=>$search_class, -title=>"Click for full info", -onClick=>"BackupFormVars(form1); form1.NEXTPAGE.value='show_info'; form1.INFO.value='".encode_entities("$prog{$pid}->{type}|$pid")."'; form1.target='_blank'; form1.submit(); RestoreFormVars(form1); form1.target='';" }, $expires ) ); # truncate the description if it is too long } elsif ( /^desc$/ ) { my $text = $prog{$pid}->{$_}; $text = substr($text, 0, 256).'...[more]' if length( $text ) > 256; push @row, td( {-class=>$search_class}, label( { -class=>$search_class, -title=>"Click for full info", -onClick=>"BackupFormVars(form1); form1.NEXTPAGE.value='show_info'; form1.INFO.value='".encode_entities("$prog{$pid}->{type}|$pid")."'; form1.target='_blank'; form1.submit(); RestoreFormVars(form1); form1.target='';" }, $text ) ); # Name / Series link } elsif ( /^name$/ ) { push @row, td( {-class=>$search_class}, label( { -class=>$search_class, -id=>'underline', -title=>"Click to list '$prog{$pid}->{$_}'", -onClick=>" BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.SEARCHFIELDS.value='name'; form1.SEARCH.value='".encode_entities('^'.$prog{$pid}->{$_}.'$')."'; form1.PAGENO.value=1; form1.submit(); RestoreFormVars(form1); "}, $prog{$pid}->{$_} ) ); # Channel link } elsif ( /^channel$/ ) { push @row, td( {-class=>$search_class}, label( { -class=>$search_class, -id=>'underline', -title=>"Click to list '$prog{$pid}->{$_}'", -onClick=>" BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.CHANNEL.value='".encode_entities('^'.$prog{$pid}->{$_}.'$')."'; form1.EXCLUDECHANNEL.value=''; form1.SEARCH.value='.*'; form1.PAGENO.value=1; form1.submit(); RestoreFormVars(form1); "}, $prog{$pid}->{$_} ) ); # Category links } elsif ( /^categories$/ ) { my @cats = split /,/, $prog{$pid}->{$_}; for ( @cats ) { my $category = $_; $_ = label( { -class=>$search_class, -id=>'underline', -title=>"Click to list '$category'", -onClick=>" BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.EXCLUDE.value=''; form1.CATEGORY.value='".encode_entities($category)."'; form1.EXCLUDECATEGORY.value=''; form1.SEARCH.value='.*'; form1.PAGENO.value=1; form1.submit(); RestoreFormVars(form1); "}, $category ); } push @row, td( {-class=>$search_class}, @cats ); # Every other column type } else { push @row, td( {-class=>$search_class}, label( { -class=>$search_class, -title=>"Click for full info", -onClick=>"BackupFormVars(form1); form1.NEXTPAGE.value='show_info'; form1.INFO.value='".encode_entities("$prog{$pid}->{type}|$pid")."'; form1.target='_blank'; form1.submit(); RestoreFormVars(form1); form1.target='';" }, $prog{$pid}->{$_} ) ); } } push @html, Tr( {-class=>$search_class}, @row ); } # Search form print $fh start_form( -name => "form1", -method => "POST", ); # Create options tabs and buttons # Build tab 'buttons' (actually list labels) # Add options buttons into the list my @optrows_nav; my @tablist = grep !/(BASICTAB|HIDDENTAB)/, @{ $layout->{taborder} }; for my $tabname ( @tablist ) { my $label = $layout->{$tabname}->{title}; # Set the colour to grey and change tab appearance if it is selected my $class = 'options_tab'; if ( defined $opt->{$tabname}->{current} && $opt->{$tabname}->{current} eq 'yes' ) { $class = 'options_tab_sel'; } push @optrows_nav, li( { -class=>$class, -id=>"li_${tabname}" }, label( { -class => 'options_outer pointer_noul', -id => 'button_'.$tabname, -title => "Show $label tab", -onClick => "show_options_tab( '$tabname', [ '".(join "', '", @tablist )."' ] );", }, $label ), ) } # add a save button on to end of list my $options_buttons = ul( { -class=>'options_tab' }, li( { -class=>'options_button' }, [ # Apply button (same as 'Search') label( { -class => 'options_outer pointer_noul', -title => 'Apply Current Options', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value=1; form1.submit(); RestoreFormVars(form1);", -role => "button", }, 'Apply Settings', ), # Save as Default button label( { -class => 'options_outer pointer_noul', -title => 'Remember Current Options as Default', -onClick => "BackupFormVars(form1); form1.SAVE.value=1; form1.submit(); RestoreFormVars(form1);", -role => "button", }, 'Save As Default', ), ] ) ); # Build each tab with it's contained options tables my @opt_td; my @opt_td_basic; for my $tabname ( @{ $layout->{taborder} } ) { my $tab = $layout->{$tabname}; my @order = @{ $tab->{order} }; my $heading = $tab->{heading}; # Set displayed tab status (i.e. style) based on posted/cookie vars (always display basic tab) $tab->{style} = "display: none; visibility: collapse;"; $tab->{style} = "display: table-cell; visibility: visible;" if $tabname eq 'BASICTAB' || ( defined $opt->{$tabname}->{current} && $opt->{$tabname}->{current} eq 'yes' ); # Each option within the tab my @optrows; #push @optrows, td( { -class=>'options' }, label( { -class => 'options_heading' }, $heading ) ) if $heading; for my $optname ( @order ) { push @optrows, build_option_html( $opt->{$optname} ); } # Set the basic search tab to be rowspan=3 if ( $tabname eq 'BASICTAB' ) { push @opt_td_basic, td( { -class=>'options_outer', -id=>"tab_${tabname}", -rowspan=>3, -style=>"$tab->{style}", -role=>'search' }, table( { -class=>'options' }, Tr( { -class=>'options' }, [ @optrows ] ) ) ); } else { push @opt_td, td( { -class=>'options_outer', -id=>"tab_${tabname}", -style=>"$tab->{style}" }, table( { -class=>'options' }, Tr( { -class=>'options' }, [ @optrows ] ) ) ); } } # Render outer options table frame (keeping some tabs hidden) print $fh table( { -class=>'options_outer' }, Tr( { -class=>'options_outer' }, (join '', @opt_td_basic). td( { -class=>'options_outer' }, ul( { -class=>'options_tab', -role=>'navigation', 'aria-label'=>'Settings' }, @optrows_nav ) ) ). Tr( { -class=>'options_outer' }, (join '', @opt_td) ). Tr( { -class=>'options_outer' }, td( { -class=>'options_outer' }, $options_buttons ) ) ); # Grey-out 'Add Current Search to PVR' button if too many programme matches my $add_search_class_suffix; $add_search_class_suffix = ' darker' if $matchcount > 30; my %action_button; $action_button{'Search'} = a( { -class => 'action', -title => 'Perform search based on search options', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value=1; form1.submit(); RestoreFormVars(form1);", }, 'Search' ); $action_button{'Queue'} = a( { -class => 'action', -title => 'Queue selected programmes (or Quick URL) for one-off recording', -onClick => "if(! ( check_if_selected(document.form1, 'PROGSELECT') || form1.URL.value ) ) { alert('No Quick URL or programmes were selected'); return false; } BackupFormVars(form1); form1.SEARCH.value=''; form1.NEXTPAGE.value='pvr_queue'; form1.submit(); RestoreFormVars(form1); form1.URL.value=''; disable_selected_checkboxes(document.form1, 'PROGSELECT');", }, 'Queue' ); $action_button{'Record'} = a( { -class => 'action', -title => 'Immediately Record selected programmes (or Quick URL) in a new tab', -onClick => "if(! ( check_if_selected(document.form1, 'PROGSELECT') || form1.URL.value ) ) { alert('No Quick URL or programmes were selected'); return false; } BackupFormVars(form1); form1.SEARCH.value=''; form1.NEXTPAGE.value='record_now'; var random=Math.floor(Math.random()*99999); form1.target='_newtab_'+random; form1.submit(); RestoreFormVars(form1); form1.target=''; form1.URL.value=''; disable_selected_checkboxes(document.form1, 'PROGSELECT');", }, 'Record' ); $action_button{'Delete'} = a( { -class => 'action', -title => 'Permanently delete selected recorded files', -onClick => "if(! check_if_selected(document.form1, 'PROGSELECT')) { alert('No programmes were selected'); return false; } BackupFormVars(form1); form1.SEARCH.value=''; form1.NEXTPAGE.value='recordings_delete'; form1.submit(); RestoreFormVars(form1);", }, 'Delete' ); $action_button{'Play'} = a( { -class => 'action', -title => 'Get a Playlist based on selected programmes for remote file streaming in your media player', -onClick => "if(! check_if_selected(document.form1, 'PROGSELECT')) { alert('No programmes were selected'); return false; } BackupFormVars(form1); form1.SEARCH.value=''; form1.ACTION.value='genplaylistdirect'; form1.submit(); RestoreFormVars(form1);", }, 'Play' ); $action_button{'Play Files'} = a( { -class => 'action', -title => 'Get a Playlist based on selected programmes for local file streaming in your media player', -onClick => "if(! check_if_selected(document.form1, 'PROGSELECT')) { alert('No programmes were selected'); return false; } BackupFormVars(form1); form1.SEARCH.value=''; form1.ACTION.value='genplaylistfile'; form1.submit(); RestoreFormVars(form1);", }, 'Play Files' ); # check for an non-whitespace advanced search entries # excluding Programme Version and Search Future Schedule my $num_adv_srch = grep /\S/, ( $opt->{EXCLUDE}->{current}, $opt->{EXCLUDECATEGORY}->{current}, $opt->{CATEGORY}->{current}, $opt->{CHANNEL}->{current}, $opt->{EXCLUDECHANNEL}->{current}, $opt->{SINCE}->{current}, $opt->{BEFORE}->{current} ); (my $escaped_search = $opt->{SEARCH}->{current}) =~ s/'/\\'/g; $action_button{'Add Search to PVR'} = a( { -class => 'action'.$add_search_class_suffix, -title => 'Create a persistent PVR search using the current search terms (i.e. all below programmes)', -onClick => "if ('".$escaped_search."' == '.*' && $num_adv_srch == 0) { alert('Search = .* will download all available programmes. Please enter a more specific search term or additional advanced search criteria (excluding $opt->{VERSIONLIST}->{title} and $opt->{FUTURE}->{title}).'); return false; } if ('".$escaped_search."' == '' ) { alert('Please enter a search term. Use Search = .* to record all programmes matching advanced search criteria.'); return false; } if ( $matchcount > 30 ) { alert('Please limit your search to result in no more than 30 current programmes'); return false; } BackupFormVars(form1); form1.NEXTPAGE.value='pvr_add'; form1.submit(); RestoreFormVars(form1);", }, 'Add Search to PVR' ); #my $autorefresh = $cgi->cookie( 'AUTOWEBREFRESH' ) || $cgi->param( 'AUTOWEBREFRESH' ); $action_button{'Refresh Cache'} = a( { -class => 'action', -title => 'Refresh the list of programmes - can take a while', -onClick => "BackupFormVars(form1); form1.target='_newtab_refresh'; form1.NEXTPAGE.value='refresh'; form1.submit(); RestoreFormVars(form1); form1.target=''; form1.NEXTPAGE.value=''; ", #-onClick => "window.frames['dataframe'].window.location.replace('?NEXTPAGE=refresh&AUTOWEBREFRESH=$autorefresh')", }, 'Refresh Cache' ); # Render action bar my @actionbar; if ( $opt->{HISTORY}->{current} ) { push @actionbar, div( { -class=>'action', -role=>'navigation', 'aria-label'=>'Actions' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ $action_button{'Search'}, $action_button{'Delete'}, $action_button{'Play'}, $action_button{'Play Files'}, ]), ), ); } else { push @actionbar, div( { -class=>'action', -role=>'navigation', 'aria-label'=>'Actions' }, ul( { -class=>'action' }, li( { -class=>'action' }, [ $action_button{'Search'}, $action_button{'Record'}, $action_button{'Queue'}, $action_button{'Add Search to PVR'}, $action_button{'Refresh Cache'}, ]), ), ); } print $fh @actionbar; print $fh @pagetrail; print $fh table( {-class=>'search', -role=>'main' }, @html ); print $fh @pagetrail; print $fh @actionbar; print $fh div( {id=>'status'} ); print $fh end_form(); return 0; } # Build page trail sub pagetrail { my ( $page, $pagesize, $count, $trailsize ) = ( @_ ); # How many pages my $pages = int( $count / $pagesize ) + 1; # If we request a page that is too high $page = $pages if $page > $pages; # Calc first and last programme numbers my $first = $pagesize * ($page - 1); my $last = $first + $pagesize; $last = $count if $last > $count; #print $se "PAGETRAIL: page=$page, first=$first, last=$first, pages=$pages, trailsize=$trailsize\n"; # Page trail my @pagetrail; push @pagetrail, td( { -class=>'pagetrail pointer' }, label( { -title => "Previous Page", -class => 'pagetrail pointer', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value=$page-1; form1.submit(); RestoreFormVars(form1);",}, "<<", )) if $page > 1; push @pagetrail, td( { -class=>'pagetrail pointer' }, label( { -title => "Page 1", -class => 'pagetrail pointer', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value=1; form1.submit(); RestoreFormVars(form1);",}, "1", )) if $page > 1; push @pagetrail, td( { -class=>'pagetrail' }, '...' ) if $page > $trailsize+2; for (my $pn=$page-$trailsize; $pn <= $page+$trailsize; $pn++) { push @pagetrail, td( { -class=>'pagetrail pointer' }, label( { -title => "Page $pn", -class => 'pagetrail pointer', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value='$pn'; form1.submit(); RestoreFormVars(form1);",}, "$pn", )) if $pn > 1 && $pn != $page && $pn < $pages; push @pagetrail, td( { -class=>'pagetrail' }, label( { -title => "Current Page", -class => 'pagetrail-current', }, "$page", )) if $pn == $page; } push @pagetrail, td( { -class=>'pagetrail' }, '...' ) if $page < $pages-$trailsize-1; push @pagetrail, td( { -class=>'pagetrail pointer' }, label( { -title => "Page ".$pages, -class => 'pagetrail pointer', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value=$pages; form1.submit(); RestoreFormVars(form1);",}, "$pages", )) if $page < $pages; push @pagetrail, td( { -class=>'pagetrail pointer' }, label( { -title => "Next Page", -class => 'pagetrail pointer', -onClick => "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value=$page+1; form1.submit(); RestoreFormVars(form1);",}, ">>", )) if $page < $pages; push @pagetrail, td( { -class=>'pagetrail' }, label( { -title => "Matches", -class => 'pagetrail',}, "($count programmes)", )); my @html = table( { -id=>'centered', -class=>'pagetrail' }, Tr( { -class=>'pagetrail' }, @pagetrail )); return ($first, $last, @html); } sub get_progs { my @params = @_; my $options = ''; my $fields; $fields .= "|<$_>" for @headings; my ( @webrequest_args ) = ( build_cmd_options( grep !/^(PVRHOLDOFF)$/, @params ), 'nopurge=1', "listformat=ENTRY${fields}" ); # Page params if ( $opt->{PAGENO}->{current} && $opt->{PAGESIZE}->{current} ) { push @webrequest_args, ( "page=$opt->{PAGENO}->{current}", "pagesize=$opt->{PAGESIZE}->{current}" ); } # Sort param push @webrequest_args, "sortreverse=$opt->{PAGENO}->{current}" if $opt->{REVERSE}->{current}; # sort reverse param push @webrequest_args, "sortmatches=$opt->{SORT}->{current}" if $opt->{SORT}->{current} && $opt->{SORT}->{current} ne 'name'; # Run command my @list = get_cmd_output( $opt_cmdline->{getiplayer}, '--encoding-locale=UTF-8', '--encoding-console-out=UTF-8', '--nocopyright', '--expiry=999999999', '--webrequest', get_iplayer_webrequest_args( @webrequest_args ), ); return ( '0', join("\n", @list) ) if $? && not $IGNOREEXIT; # Get total matches count my $matchcount = pop @list; $matchcount = $1 if $matchcount =~ m{^INFO:\s*(\d+?)\s+}; for ( grep /^ENTRY/, @list ) { chomp(); # Strip white space s/\|\s*$//; my $record; my @element = split /\|/, $_; shift @element; # Put data for this contact into temporary record hash for this user for (my $i=0; $i <= $#headings; $i++) { $record->{$headings[$i]} = $element[$i]; } my $search_class = 'search'; # get the real path if file is defined $record->{filename} = search_absolute_path( $record->{filename} ) if $record->{filename} && $record->{filename} ne ""; # store record in the prog global hash (prog => pid) $prog{ $record->{'pid'} } = $record; push @pids, $record->{'pid'}; } return ( $matchcount, '' ); } # # Get the columns to display # sub get_display_cols { @displaycols = (); # Set default status for columns options tab checkboxes my %cols_status; # Add some default headings for history mode push @headings_default, 'mode' if $opt->{HISTORY}->{current}; # Determine which columns to display (all if $cols not defined) my $cols = join(",", $opt->{COLS}->{current} ) || join ',', @headings_default; my @columns = split /,/, $cols; # Re-sort selected display columns into original header order for my $heading (@headings) { if ( grep /^$heading$/, @columns ) { # Remove display of mode and filename if not history mode if ( ( ! $opt->{HISTORY}->{current} ) && $heading =~ /^(mode|filename)$/ ) { # skip } else { push @displaycols, $heading; } $cols_status{$heading} = 1; } } # Make sure we select all if no cols are specified @displaycols = @headings_default if $#displaycols < 0; # Set defaults for checkboxes $opt->{COLS}->{status} = \%cols_status; # Rebuild the hash for the checkboxes %cols_order = (); %cols_names = (); for ( my $i = 0; $i <= $#headings; $i++ ) { $cols_names{$headings[$i]} = $fieldname{$headings[$i]}; $cols_order{$i} = $headings[$i]; } return 0; } ############################################# # # Form Header # ############################################# sub form_header { my $request_host = shift; my $nextpage = shift || $cgi->param( 'NEXTPAGE' ); print $fh $cgi->start_form( -name => "formheader", -method => "POST", ); # set $class for tab selection in nav bar my $class = {}; $class->{search} = 'nav_tab'; $class->{recordings} = 'nav_tab'; $class->{pvrlist} = 'nav_tab'; $class->{pvrrun} = 'nav_tab'; $class->{search} = 'nav_tab_sel' if ( $nextpage eq 'search_progs' || ! $nextpage ) && ! $opt->{HISTORY}->{current}; $class->{recordings} = 'nav_tab_sel' if $nextpage eq 'search_history' || $opt->{HISTORY}->{current}; $class->{pvrrun} = 'nav_tab_sel' if $nextpage eq 'pvr_run'; $class->{pvrlist} = 'nav_tab_sel' if $nextpage =~ m{^(pvr_list|pvr_queue|pvr_del)$}; print $fh div( { -class=>'nav', -role=>'navigation' }, ul( { -class=>'nav' }, li( { -id=>'logo', -class=>'nav_tab' }, span( { -class=>'logotext' }, 'get_iplayer' ) ). li( { -class=>$class->{search} }, a( { -class=>'nav', -title=>'Main search page', -onClick => "BackupFormVars(formheader); formheader.NEXTPAGE.value='search_progs'; formheader.submit(); RestoreFormVars(formheader);" }, 'Search' ) ). li( { -class=>$class->{recordings} }, a( { -class=>'nav', -title=>'History search page', -onClick => "BackupFormVars(formheader); formheader.NEXTPAGE.value='search_history'; formheader.submit(); RestoreFormVars(formheader);" }, 'Recordings' ) ). li( { -class=>$class->{pvrlist} }, a( { -class=>'nav', -title=>'List all saved PVR searches', -onClick => "BackupFormVars(formheader); formheader.NEXTPAGE.value='pvr_list'; formheader.submit(); RestoreFormVars(formheader);" }, 'PVR List' ) ). li( { -class=>$class->{pvrrun} }, a( { -class=>'nav', -title=>'Run the PVR now - wait for the PVR to complete', -onClick => "BackupFormVars(formheader); formheader.NEXTPAGE.value='pvr_run'; formheader.target='_newtab_pvrrun'; formheader.submit(); RestoreFormVars(formheader); formheader.target='';" }, 'Run PVR' ) ). li( { -class=>'nav_tab' }, a( { -class=>'nav', -title=>'Show help and instructions', -href => "https://github.com/get-iplayer/get_iplayer/wiki/webpvr", -target => "_new" }, 'Help' ) ) ), ); print $fh hidden( -name => 'AUTOPVRRUN', -value => $opt->{AUTOPVRRUN}->{current}, -override => 1 ); print $fh hidden( -name => 'NEXTPAGE', -value => 'search_progs', -override => 1 ); print $fh $cgi->end_form(); } # Form Footer sub form_footer { #print $fh ""; #print $fh ""; # print $fh p( b({-class=>"footer"}, "get_iplayer Web PVR Manager $VERSION_TEXT, ©2009-2010 Phil Lewis - Licensed under GPLv3" )); } # End HTML sub html_end { print $fh "\n"; print $fh "\n\n"; } # Gets and sets the CGI parameters (POST/Cookie) in the $opt hash - also sets $opt{VAR}->{current} from default or POST sub process_params { # Store options definition here as hash of 'name' => [options] $opt->{SEARCH} = { title => 'Search', # Title tooltip => 'Enter your partial text match (or regex expression)', # Tooltip webvar => 'SEARCH', # webvar optkey => 'search', # option key type => 'text', # type default => '.*', # default value => 20, # width values save => 0, }; $opt->{URL} = { title => 'Quick URL', # Title tooltip => "Enter your URL for Recording (then click 'Record' or 'Play')", # Tooltip webvar => 'URL', # webvar type => 'text', # type default => '', # default value => 36, # width values save => 0, }; $opt->{SEARCHFIELDS} = { title => 'Search in', # Title tooltip => 'Select which column you wish to search', # Tooltip webvar => 'SEARCHFIELDS', # webvar optkey => 'fields', # option type => 'popup', # type label => \%fieldname, # labels default => 'name', # default value => [ (@headings,'name,episode','name,episode,desc') ], # values save => 1, }; $opt->{PAGESIZE} = { title => 'Programmes per Page', # Title tooltip => 'Select the number of search results displayed on each page', # Tooltip webvar => 'PAGESIZE', # webvar type => 'popup', # type default => 20, # default value => ['10','25','50','100','200','400'], # values onChange=> "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.PAGENO.value=1; form1.submit(); RestoreFormVars(form1);", save => 1, }; $opt->{SORT} = { title => 'Sort by', # Title tooltip => 'Sort the results in this order', # Tooltip webvar => 'SORT', # webvar type => 'popup', # type label => \%fieldname, # labels default => 'index', # default value => [@headings], # values onChange=> "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.submit(); RestoreFormVars(form1);", save => 1, }; $opt->{REVERSE} = { title => 'Reverse sort', # Title tooltip => 'Reverse the sort order', # Tooltip webvar => 'REVERSE', # webvar type => 'radioboolean', # type #onChange=> "BackupFormVars(form1); form1.NEXTPAGE.value='search_progs'; form1.submit(); RestoreFormVars(form1);", default => '0', # value save => 1, }; $opt->{PROGTYPES} = { title => 'Programme type', # Title tooltip => 'Select the programme types you wish to search', # Tooltip webvar => 'PROGTYPES', # webvar optkey => 'type', # option type => 'multiboolean', # type label => \%prog_types, # labels default => 'tv', #status => \%type, # default status value => \%prog_types_order, # order of values save => 1, }; $opt->{MODES} = { title => 'Recording Modes', # Title tooltip => 'Comma separated list of recording modes which should be tried in order. Default is "best" for HD TV (if available, with fallback to SD TV). Set to "better" (without quotes) for best available SD TV. Set to "good" (without quotes) for lower-quality SD TV.', # Tooltip webvar => 'MODES', # webvar optkey => 'modes', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{OUTPUT} = { title => 'Override Recordings Folder', # Title tooltip => 'Folder on the server where recordings should be saved', # Tooltip webvar => 'OUTPUT', # webvar optkey => 'output', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{PROXY} = { title => 'Web Proxy URL', # Title tooltip => 'e.g. http://192.168.1.2:8080', # Tooltip webvar => 'PROXY', # webvar optkey => 'proxy', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{VERSIONLIST} = { title => 'Programme Version', # Title tooltip => 'Comma separated list of versions to try to record in order (e.g., "signed,default" or "audiodescribed,default")', # Tooltip webvar => 'VERSIONLIST', # webvar optkey => 'versionlist', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{EXCLUDE} = { title => 'Exclude Programmes', # Title tooltip => 'Comma separated list of programmes to exclude. Partial word matches and regular expressions are supported', # Tooltip webvar => 'EXCLUDE', # webvar optkey => 'exclude', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{CATEGORY} = { title => 'Categories Containing', # Title tooltip => 'Comma separated list of categories to match. Partial word matches and regular expressions are supported. Only works in Recordings tab.', # Tooltip webvar => 'CATEGORY', # webvar optkey => 'category', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{EXCLUDECATEGORY} = { title => 'Exclude Categories Containing', # Title tooltip => 'Comma separated list of categories to exclude. Partial word matches and regular expressions are supported. Only works in Recordings tab.', # Tooltip webvar => 'EXCLUDECATEGORY', # webvar optkey => 'excludecategory', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{CHANNEL} = { title => 'Channels Containing', # Title tooltip => 'Comma separated list of channels to match. Partial word matches and regular expressions are supported', # Tooltip webvar => 'CHANNEL', # webvar optkey => 'channel', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{EXCLUDECHANNEL} = { title => 'Exclude Channels Containing', # Title tooltip => 'Comma separated list of channels to exclude. Partial word matches and regular expressions are supported', # Tooltip webvar => 'EXCLUDECHANNEL', # webvar optkey => 'excludechannel', # option type => 'text', # type default => '', # default value => 30, # width values save => 1, }; $opt->{HIDE} = { title => 'Hide Recorded', # Title tooltip => 'Whether to hide programmes that have already been successfully recorded', # Tooltip webvar => 'HIDE', # webvar optkey => 'hide', # option type => 'radioboolean', # type default => '0', # value save => 1, }; $opt->{FORCE} = { title => 'Force Recording', # Title tooltip => "Ignore the history and re-record a programme (Please delete the existing recording first). Doesn't apply to PVR Searches or 'Add Series'", # Tooltip webvar => 'FORCE', # webvar optkey => 'force', # option type => 'radioboolean', # type default => '0', # value save => 1, }; $opt->{REFRESHFUTURE} = { title => 'Refresh Future Schedule', # Title tooltip => "When Refresh is clicked also get the future programme schedule. This will take a longer time to index.", # Tooltip webvar => 'REFRESHFUTURE', # webvar optkey => 'refreshfuture', # option type => 'radioboolean', # type default => '0', # value save => 1, }; my %metadata_labels = ( ''=>'Off', generic=>'Generic XML' ); $opt->{METADATA} = { title => 'Download Metadata', # Title tooltip => 'Format of metadata file to create when recording', # Tooltip webvar => 'METADATA', # webvar optkey => 'metadata', # option type => 'popup', # type #label => \%fieldname, # labels label => \%metadata_labels, # labels default => '', # default value => [ ( '', 'generic' ) ], # values save => 1, }; $opt->{SUBTITLES} = { title => 'Download Subtitles', # Title tooltip => 'Whether to download the subtitles when recording', # Tooltip webvar => 'SUBTITLES', # webvar optkey => 'subtitles', # option type => 'radioboolean', # type default => '0', # value save => 1, }; $opt->{THUMB} = { title => 'Download Thumbnail', # Title tooltip => 'Whether to download the thumbnail when recording', # Tooltip webvar => 'THUMB', # webvar optkey => 'thumb', # option type => 'radioboolean', # type default => '0', # value save => 1, }; $opt->{AUTOWEBREFRESH} = { title => 'Auto-Refresh Cache Interval', # Title tooltip => 'Automatically refresh the default caches in another browser tab (hours)', # Tooltip webvar => 'AUTOWEBREFRESH', # webvar type => 'text', # type default => 1, # default value => 3, # width values save => 1, }; $opt->{AUTOPVRRUN} = { title => 'Auto-Run PVR Interval', # Title tooltip => 'Automatically run the PVR in another browser tab (hours)', # Tooltip webvar => 'AUTOPVRRUN', # webvar type => 'text', # type default => 4, # default value => 3, # width values save => 1, }; $opt->{HISTORY} = { title => 'Search History', # Title tooltip => 'Whether to display and search programmes in the recordings history', # Tooltip webvar => 'HISTORY', # webvar optkey => 'history', # option type => 'boolean', # type default => '0', # value save => 0, }; $opt->{FUTURE} = { title => 'Search Future Schedule', # Title tooltip => 'Whether to additionally display and search programmes in the future programmes schedule (will only work if Refresh future schedule option is enable and refreshed)', # Tooltip webvar => 'FUTURE', # webvar optkey => 'future', # option type => 'radioboolean', # type default => '0', # value save => 1, }; $opt->{SINCE} = { title => 'Added Since (hours)', # Title tooltip => 'Only show programmes added to the local programmes cache in the past number of hours', # Tooltip webvar => 'SINCE', # webvar optkey => 'since', # option type => 'text', # type value => 3, # width values default => '', save => 1, }; $opt->{BEFORE} = { title => 'Added Before (hours)', # Title tooltip => 'Only show programmes added to the local programmes cache over this number of hours ago', # Tooltip webvar => 'BEFORE', # webvar optkey => 'before', # option type => 'text', # type value => 3, # width values default => '', save => 1, }; $opt->{PVRHOLDOFF} = { title => 'PVR Hold off period (hours)', # Title tooltip => 'Wait this number of hours before allowing the PVR to record a programme. This sometimes helps when the flashhd version is delayed in being made available.', # Tooltip webvar => 'PVRHOLDOFF', # webvar optkey => 'before', # option type => 'text', # type value => 3, # width values default => '', save => 1, }; my %vsize_labels = ( ''=>'Native', '1280x720'=>'1280x720', '832x468'=>'832x468', '640x360'=>'640x360', '512x288'=>'512x288', '480x272'=>'480x272', '320x176'=>'320x176', '176x96'=>'176x96' ); $opt->{VSIZE} = { title => 'Remote Streaming Video Size', # Title tooltip => "Video size 'x' to transcode remotely played files - leave blank for native size", # Tooltip webvar => 'VSIZE', # webvar type => 'popup', # type label => , \%vsize_labels, # labels default => '', # default value => [ (sort {$a <=> $b} keys %vsize_labels) ], # values save => 1, }; $opt->{BITRATE} = { title => 'Remote Audio Bitrate', # Title tooltip => 'Remote Audio Bitrate (in kbps) to transcode remotely played files - leave blank for native bitrate', # Tooltip webvar => 'BITRATE', # webvar type => 'text', # type value => 3, # width values default => '', save => 1, }; $opt->{VFR} = { title => 'Remote Video Frame Rate', # Title tooltip => 'Remote Video Frame Rate (in frames per second) to transcode remotely played files - leave blank for native framerate', # Tooltip webvar => 'VFR', # webvar type => 'text', # type value => 2, # width values default => '', save => 1, }; my %streamtype_labels = ( ''=>'Auto', 'none'=>'Disable Transcoding', 'flv'=>'Flash Video (flv)', 'mov'=>'Quicktime (mov)', 'asf'=>'Advanced Streaming Format (asf)', 'avi'=>'AVI', 'mp3'=>'MP3 (Audio Only)', 'aac'=>'AAC (Audio Only)', 'wav'=>'WAV (Audio Only)', 'flac'=>'FLAC (Audio Only)' ); $opt->{STREAMTYPE} = { title => "Remote Streaming type", # Title tooltip => "Force the output to be this type when using 'Play Remote' for 'PlayDirect' streaming(e.g. flv, mov). Specify 'none' to disable transcoding/remuxing. Leave blank for auto-detection", # Tooltip webvar => 'STREAMTYPE', # webvar type => 'popup', # type label => , \%streamtype_labels, # labels default => '', # default value => [ '', 'none', 'flv', 'mov', 'asf', 'avi', 'mp3', 'aac', 'wav', 'flac' ], # values onChange=> "form1.submit();", save => 1, }; # Whether to hide deleted programmes from the Recordings display. $opt->{HIDEDELETED} = { title => 'Hide Deleted Recordings', # Title tooltip => 'Whether to hide deleted programmes from the recordings history list', # Tooltip webvar => 'HIDEDELETED', # webvar optkey => 'skipdeleted', # option type => 'radioboolean', # type default => 0, # value save => 1, }; # Which columns to display $opt->{COLS} = { title => 'Enable Columns', # Title tooltip => 'Select the columns you wish to display', # Tooltip webvar => 'COLS', # webvar #optkey => 'type', # option type => 'multiboolean', # type label => \%cols_names, # labels #status => \%cols_status, # default status value => \%cols_order, # order of values save => 1, }; # Make sure we go to the correct nextpage for processing $opt->{NEXTPAGE} = { webvar => 'NEXTPAGE', type => 'hidden', default => 'search_progs', save => 0, }; # Make sure we go to the correct nextpage for processing $opt->{ACTION} = { webvar => 'ACTION', type => 'hidden', default => '', save => 0, }; # Make sure we go to the correct next page no. $opt->{PAGENO} = { webvar => 'PAGENO', type => 'hidden', default => 1, save => 0, }; # Remeber the status of the tab options display for my $tabname ( grep !/BASICTAB/, @{ $layout->{taborder} } ) { my $default = 'no'; # By default only show advanced search tab $default = 'yes' if $tabname eq 'SEARCHTAB'; $opt->{$tabname} = { webvar => $tabname, # webvar type => 'hidden', # type default => $default, # value save => 0, }; } # Save the status of the Advanced Search options and preferences settings $opt->{SAVE} = { webvar => 'SAVE', # webvar type => 'hidden', # type default => '0', # value save => 0, }; # INFO for page info if clicked $opt->{INFO} = { webvar => 'INFO', type => 'hidden', default => 0, save => 0, }; # Go through each of the options defined above for ( keys %{ $opt } ) { # Ignore cookies if we are saving new ones if ( not $cgi->param('SAVE') ) { if ( defined $cgi->param($_) ) { print $se "DEBUG: GOT Param $_ = ".$cgi->param($_)."\n" if $opt_cmdline->{debug}; $opt->{$_}->{current} = join ",", $cgi->param($_); } elsif ( defined $cgi->cookie($_) ) { print $se "DEBUG: GOT Cookie $_ = ".$cgi->cookie($_)."\n" if $opt_cmdline->{debug}; $opt->{$_}->{current} = join ",", $cgi->cookie($_); } else { $opt->{$_}->{current} = join ",", $opt->{$_}->{default}; } print $se "DEBUG: Using $_ = $opt->{$_}->{current}\n--\n" if $opt_cmdline->{debug}; } else { $opt->{$_}->{current} = join(",", $cgi->param($_) ) || $opt->{$_}->{default} if not defined $opt->{$_}->{current}; } } } ###################################################################### # # begin_html # # Send HTTP headers to browser # Sets "title", Sends and flags # ###################################################################### sub begin_html { my $request_host = shift; my $mimetype = 'text/html'; # Save settings if selected my @cookies; if ( $cgi->param('SAVE') ) { print $se "DEBUG: Sending cookies\n"; for ( %{ $opt } ) { # skip if opt not allowed to be saved next if not $opt->{$_}->{save}; my $cookie = $cgi->cookie( -name=>$_, -value=>$opt->{$_}->{current}, -expires=>'+1y' ); push @cookies, $cookie; print $se "DEBUG: Sending cookie: $cookie\n" if $opt_cmdline->{debug}; } # Ensure SAVE state is reset to off $opt->{SAVE}->{current} = 0; } # Send the headers to the browser my $headers = $cgi->header( -type => $mimetype, -charset => 'utf-8', -cookie => [@cookies], ); print $se "\nHEADERS:\n$headers\n" if $opt_cmdline->{debug}; # Build body element and page title differently depending on the type of page # Load the refresh tab if required my $body_element; my $title; my $autorefresh = $cgi->cookie( 'AUTOWEBREFRESH' ) || $cgi->param( 'AUTOWEBREFRESH' ); my $autopvrrun = $cgi->cookie( 'AUTOPVRRUN' ) || $cgi->param( 'AUTOPVRRUN' ); if ( $autorefresh && $cgi->param( 'NEXTPAGE' ) eq 'refresh' ) { $body_element = "{PROGTYPES}->{current}', ".(1000*3600*$autorefresh)." );\">"; $title = 'Refreshing Cache: get_iplayer Web PVR Manager'; } elsif ( $autopvrrun && $cgi->param( 'NEXTPAGE' ) eq 'pvr_run' ) { $body_element = ""; $title = 'Running PVR: get_iplayer Web PVR Manager'; } else { $body_element = "\n"; $title = "get_iplayer Web PVR Manager $VERSION_TEXT"; } # Write out the page http and html headers print $fh $headers; print $fh ''."\n"; print $fh ""; print $fh "$title\n"; insert_stylesheet(); print $fh "\n"; insert_javascript(); print $fh $body_element; } ############################################# # # Javascript Functions here # ############################################# sub insert_javascript { print $fh < function RefreshTab(url, time, force ) { if ( force ) { window.location.href = url; } setTimeout( "RefreshTab('" + url + "'," + time + ", 1 )", time ); } // global hash table for saving copy of form var form_backup = {}; // // Copy all non-grouped form values into a global hash // function BackupFormVars( f ) { // empty out array for(var key in form_backup) { delete( form_backup[key] ); } // copy forms elements var elem = f.elements; for(var i = 0; i < elem.length; i++) { // exclude radio and checkbox types - can be duplicate names in groups... if ( elem[i].type != "checkbox" && elem[i].type != "radio" ) { form_backup[ elem[i].name ] = elem[i].value; } } } // // Copy all form values in the global hash into the specified form // function RestoreFormVars( f ) { // copy form elements for(var key in form_backup) { f.elements[ key ].value = form_backup[key]; // delete element delete( form_backup[key] ); } } // // Hide show an element (and modify the text of the button/label) // e.g. document.getElementById('advanced_opts').style.display='table'; // // Usage: show_options_tab( SELECTEDID, [ 'TAB1', 'TAB2' ] ); // Displays first tab in list or tab suffixes // tab_TAB1 is the table element // option_TAB1 is the form variable // button_TAB1 is the label // function show_options_tab( selectedid, tabs ) { // selected tab element var selected_tab = document.getElementById( 'tab_' + selectedid ); // Loop through the above tab elements for(var i = 0; i < tabs.length; i++) { var li = document.getElementById( 'li_' + tabs[i] ); var tab = document.getElementById( 'tab_' + tabs[i] ); var option = document.getElementById( 'option_' + tabs[i] ); var button = document.getElementById( 'button_' + tabs[i] ); if ( tab == selected_tab ) { tab.style.display = 'table-cell'; tab.style.visibility = 'visible'; option.value = 'yes'; //button.innerHTML = '- ' + button.innerHTML.substring(2); //button.style.color = '#F54997'; //li.style.borderBottom = '0px solid #666'; li.className = 'options_tab_sel'; } else { tab.style.display = 'none'; tab.style.visibility = 'collapse'; option.value = 'no'; //button.innerHTML = '+ ' + button.innerHTML.substring(2); //button.style.color = '#ADADAD'; //li.style.borderBottom = '1px solid #666'; li.className = 'options_tab'; } } return true; } // // Check/Uncheck all checkboxes named // function check_toggle(f, name) { var empty_fields = ""; var errors = ""; var check; if (f.SELECTOR.checked == true) { check = 1; } else { check = 0; } // Loop through the elements of the form for(var i = 0; i < f.length; i++) { var e = f.elements[i]; if (e.type == "checkbox" && e.name == name) { if (check == 1) { // First check if the box is checked (don't check a disabled box) if(e.checked == false && e.disabled == false) { e.checked = true; } } else { // First check if the box is not checked if(e.checked == true) { e.checked = false; } } } } return true; } // // Warn if none of the checkboxes named are selected // function check_if_selected(f, name) { // Loop through the elements of the form for(var i = 0; i < f.length; i++) { var e = f.elements[i]; if (e.type == "checkbox" && e.name == name && e.checked == true) { return true; } } return false; } // // Disable checkboxes named that are selected // function disable_selected_checkboxes(f, name) { var empty_fields = ""; var errors = ""; var check; // Loop through the elements of the form for(var i = 0; i < f.length; i++) { var e = f.elements[i]; if (e.type == "checkbox" && e.name == name) { // First check if the box is checked if(e.checked == true) { e.checked = false; e.disabled = true; } } } return true; } // // Submit Search only if enter is pressed from a textfield // Called as: onKeyDown="return submitonEnter(event);" // function submitonEnter(evt){ var charCode = (evt.which) ? evt.which : event.keyCode if ( charCode == "13" ) { document.form1.NEXTPAGE.value='search_progs'; document.form1.PAGENO.value=1; document.form1.submit(); } } EOF } ############################################# # # CSS1 Styles here # ############################################# sub insert_stylesheet { print $fh < body { background: #000; color: #fff; font-family: Arial,Helvetica,sans-serif; font-size: 100%; } img { border: 0; } input, select { background: #ddd; border: 0; } input { font-size: 1em; } a { color: #fff; text-decoration: none; } a[href], a[onclick], label[onclick], :link, :visited { cursor: pointer; } ul.nav, ul.options_tab, ul.action { list-style: none; margin: 8px 0; padding: 0; } ul.nav, ul.action { font-size: 1em; } ul.nav { border-bottom: 4px solid #888; } ul.options_tab { border-bottom: 2px solid #888; } ul.nav > li, ul.options_tab > li, ul.action > li { background: #444; display: inline-block; vertical-align: bottom; margin: 0 4px; } ul.nav > li, ul.action > li { padding: 4px 16px; } ul.options_tab > li { padding: 2px 8px; } ul.nav > li:hover, ul.options_tab > li:hover, ul.action > li:hover { background: #666; } ul.nav > li.nav_tab_sel, ul.options_tab > li.options_tab_sel { background: #888; } table.options_outer > tbody > tr { font-size: 0.875em; } table.options_outer td, table.options_outer th, table.info td, table.info th { vertical-align: top; text-align: left; } table.options, table_options_embedded { border-spacing: 1; } table.pagetrail { margin-left: auto; margin-right: auto; margin-top: 8px; margin-bottom: 8px; font-size: 1em; font-weight: bold; border-spacing: 10px 0; padding: 0px; } label.pagetrail-current { color: #F54997; } table.search, table.info { border: 2px solid #333; border-collapse: collapse; width: 100%; } table.search > tbody > tr, table.info > tbody > tr { background: #444; font-size: 0.875em; } table.search > tbody > tr:hover, table.info > tbody > tr:hover { background: #666; } table.search > tbody > tr > th, table.info > tbody > tr > th { background: #000; text-align: center; } table.search > tbody > tr > td, table.search > tbody > tr > th, table.info > tbody > tr > td, table.info > tbody > tr > th { border: 1px solid #333; padding: 4px 8px; } table.searchhead { width: 100%; } label.sorted { color: #CFC; } label.sorted_reverse { color: #FCC; } b.footer { color: #777; font-size: 0.75em; font-weight: normal; } #nowrap { white-space: nowrap; } #logo { background: none; margin: 0; } #logo .logotext { color: #F54997; font-family: "Courier New", monospace; } .darker { color: #7D7D7D; } EOF }