File Coverage

lib/Video/NRK/Cache/Store.pm

Criterion	Covered	Total	%
statement	23	23	100.0
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	31	31	100.0

use v5.37.9;
use feature 'class';
no warnings 'experimental::class';
use open qw( :utf8 :std );

package Video::NRK::Cache::Store 3.02;  # Dist::Zilla doesn't know about class yet

class Video::NRK::Cache::Store;
# ABSTRACT: Store NRK Video on Demand cache on disk (abstract base class)


use Carp qw( croak );
use Cwd qw( cwd );
use Path::Tiny 0.125 qw( path );
use List::Util qw( max );


our $RATE = 1600;  # kilo-bytes per second
our $NICE = 1;
our $DRY_RUN = 0;


field $program_id :param;
field $url        :param;
field $meta_title :param = $program_id;
field $meta_desc  :param = '';
field $options    :param = {};

field $dir;
field $file;
field $dir_mp4;
field %dir_sub;
field $nice = $NICE;
field $quality = 3;

# :reader
method program_id () { $program_id }
method url        () { $url }
method meta_title () { $meta_title }
method meta_desc  () { $meta_desc }
method options    () { $options }

method dir     () { $dir }
method file    () { $file }
method dir_mp4 () { $dir_mp4 }
method dir_sub () { %dir_sub }
method nice    () { $nice }
method quality () { $quality }


ADJUST {
	$quality = $options->{quality} if defined $options->{quality};
	$nice = $options->{nice} if defined $options->{nice};

	$dir = path(cwd)->child("$meta_title");
	$file = path(cwd)->child("$meta_title.mp4");
	$dir_mp4 = $dir->child("$program_id.mp4");
	$dir_sub{nb_ttv} = $dir->child("$program_id.nb-ttv.vtt");
	$dir_sub{nb_nor} = $dir->child("$program_id.nb-nor.vtt");
	$dir_sub{nn_ttv} = $dir->child("$program_id.nn-ttv.vtt");
	$dir_sub{nn_nor} = $dir->child("$program_id.nn-nor.vtt");
	$dir_sub{ffmpeg} = $dir->child("$program_id.ffmpeg.vtt");
}


method create () {
	$self->prep;
	$self->download;
	$self->ffmpeg;
	$self->post;
}


method rate () {
	return unless $nice;
	return max 1, int $RATE / 2 ** ($nice - 1);
}


method prep () {
	croak "File exists: $file" if $file->exists;
	$dir->mkdir;
}


method ffmpeg () {
	my @codecs = (
		'-c:v' => $options->{vcodec} ? split ' ', $options->{vcodec} : 'copy',
		'-c:a' => $options->{acodec} ? split ' ', $options->{acodec} : 'copy',
	);
	croak "acodec/vcodec must have uneven number of items" if @codecs & 1;  # won't catch the mess if both are wrong
	my $dir_sub = $dir_sub{nb_ttv}->exists ? $dir_sub{nb_ttv} :
		$dir_sub{nn_ttv}->exists ? $dir_sub{nn_ttv} :
		$dir_sub{nb_nor}->exists ? $dir_sub{nb_nor} :
		$dir_sub{nn_nor}->exists ? $dir_sub{nn_nor} :
		undef;
	if ($dir_sub) {

		# As of 2025, many NRK subs lack a space after . It's a problem
		# with the original data: The NRK web player is affected, too.
		my $sub = path($dir_sub)->slurp_raw;
		$sub =~ s{(?=\w)}{ }g;
		path($dir_sub{ffmpeg})->spew_raw($sub);

		@codecs = (
			-f => 'srt', -i => "$dir_sub{ffmpeg}",
			qw( -map 0:0 -map 0:1 -map 1:0 ), @codecs, qw( -c:s mov_text ),
		);
		# https://trac.ffmpeg.org/wiki/Map
	}
	$self->system( 'ffmpeg',
		-i => "$dir_mp4",
		@codecs,
		-metadata => "description=$meta_desc",
		-metadata => "comment=$url",
		-metadata => "copyright=NRK",
		-metadata => "episode_id=$program_id",
		"$file",
	);
}


method post () {
	$dir->remove_tree;
}


method system ($cmd, @args) {
	say join " ", $cmd, @args;
	system $cmd, @args unless $DRY_RUN;
	$self->_ipc_error_check($!, $?, $cmd);
}


method _ipc_error_check ($os_err, $code, $cmd) {
	utf8::decode $os_err;
	croak "$cmd failed to execute: $os_err" if $code == -1;
	croak "$cmd died with signal " . ($code & 0x7f) if $code & 0x7f;
	croak "$cmd exited with status " . ($code >> 8) if $code;
}


1;

__END__