The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package App::VideoMixer::External::FFmpeg;
use strict;

use vars qw($VERSION);
$VERSION = '0.02';

use parent 'Class::Accessor';
__PACKAGE__->mk_accessors(qw(width height depth pid stream texture_id file pixel_format ffmpeg));

sub spawn {
    my ($self,$cmd) = @_;
    my $pid = open my $stream, $cmd
        or die "Couldn't spawn '$cmd': $!/$?";
    binmode $stream;
    return ($pid,$stream)
};

sub DESTROY {
    if (my $pid = $_[0]->pid) {
        kill 9, $pid
    };
};

package App::VideoMixer::Source::FFmpeg;
use strict;
use OpenGL qw(:all);
use OpenGL::SimpleNames;
use OpenGL::Tools;
use parent -norequire => 'App::VideoMixer::External::FFmpeg';
use IPC::Open3 qw(open3);

use vars qw($VERSION);
$VERSION = '0.02';

sub stream_info {
    my ($self,$filename) = @_;
    my ($child_in, $stream, $info);
    my $cmd = sprintf qq{%s -t 0 -i "%s" -},
        $self->ffmpeg,
        $filename;
    my $pid = open3 $child_in, $stream, $stream, $cmd
        or die "Couldn't spawn '$cmd': $!/$?";

    while (my $line = <$stream>) {
        #print ">>$line";
        if ($line =~ /Video: .*/) {
            chomp $line;
            #print ">$line<\n";
            my ($width,$height) = $line =~ /(\d+)x(\d+)/;
            return ($width,$height);
        };
    };
};

sub new {
    my ($class,%args) = @_;
    my $file = delete $args{filename};
    die "No file: '$file'"
        unless -f $file;

    my $depth = 3;

    my $self = $class->SUPER::new({
        depth => $depth,
        stream => undef,
        pid => undef,
        loop => 1,
        file => $file,
        pixel_format => 'rgb24',
        ffmpeg => 'bin\\ffmpeg.exe',
        %args,
    });
    my ($width,$height) = $self->stream_info($file);
    $self->width($width);
    $self->height($height);
    my $pixel_format = $self->pixel_format;
    $self->rewind(sprintf qq{%s -i "%s" -f rawvideo -pix_fmt %s - |}, $self->ffmpeg, $file, $pixel_format);
    $self
};

sub rewind {
    my ($self) = @_;
    my $file = $self->file;
    my $pixel_format = $self->pixel_format;
    my ($pid,$stream) = $self->spawn(sprintf qq{%s -i "%s" -f rawvideo -pix_fmt %s - |},
        $self->ffmpeg, $file, $pixel_format
    );
    $self->pid($pid);
    $self->stream($stream);
    1;
};

sub tick {
    my ($self) = @_;

    my $texture_id = $self->texture_id;
    if (! $texture_id) {
        ($texture_id) = glGenTextures_p(1);
        $self->texture_id($texture_id);
    };

    my $frame;
    my $retries = 3;
    while ($retries-- and ! read $self->stream, $frame, $self->width * $self->height * $self->depth) {
        $self->rewind();
    };
    if (! $frame) {
        die "Read failure: $!";
    };
    OpenGL::Tools::set_texture_pixels(
        texture => $texture_id,
        pixels => $frame,
        width => $self->width,
        height => $self->height,
        depth => $self->depth
    );

    $texture_id
};

package App::VideoMixer::Target::FFmpeg;
use strict;
use OpenGL qw(:all);
use OpenGL::SimpleNames;
use OpenGL::Tools;
use parent -norequire => 'App::VideoMixer::External::FFmpeg';

use vars qw($VERSION);
$VERSION = '0.02';

sub new {
    my ($class,%args) = @_;
    my $file = delete $args{filename};
    my $width = delete $args{width} || 352;
    my $height = delete $args{height} || 288;
    my $in_width = delete $args{in_width} || $width;
    my $in_height = delete $args{in_height} || $height;
    my $pixel_format = delete $args{pixel_format} || 'rgb42';
    $args{ffmpeg} ||= "bin\\ffmpeg";

    my $depth = 3;

    my ($pid,$stream) = $class->spawn(sprintf qq{| %s -y -f rawvideo -pix_fmt %s -s ${in_width}x${in_height} -i "-" -f mpeg2video -s ${width}x${height} "$file"},
        $args{ffmpeg}, $pixel_format
    );
    my $self = $class->SUPER::new({
        width => $width,
        height => $height,
        depth => $depth,
        stream => $stream,
        pid => $pid,
        pixel_format => $pixel_format,
        %args,
    });

    $self
};

sub tick {
    my ($self,$texture_id) = @_;

    # Should we scale in the GPU instead of CPU/ffmpeg?
    # Then, a texture-copy would be in order here...

    # save current frame from input fbo
    glBindTexture(GL_TEXTURE_2D, $texture_id);
    #glReadPixels_s(0,0,$self->width,$self->height,GL_RGB,GL_UNSIGNED_BYTE,my $frame);
    my $frame;
    for my $i (reverse (0..$self->height-1)) {
        glReadPixels_s(0,$i,$self->width,1,GL_RGB,GL_UNSIGNED_BYTE,my $line);
        $frame .= $line;
    };
    syswrite $self->stream, $frame, $self->width * $self->height * $self->depth
        or die "Write failure";

    # and claim the current texture id were ours
    $texture_id
};

1;