File Coverage

blib/lib/Video/Manip.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Video::Manip;

#XXX DataDumper has problems with strict
#use strict;

use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = 0.01;
use base qw(Exporter);
@EXPORT = qw(new use extract);
@EXPORT_OK = qw(check getbdys buildcool match redefineenvl reconsevents selectframes);
%EXPORT_TAGS = ( all => [@EXPORT_OK] );

use Video::Event::Manual;
use Video::Function;
use Video::FindEvent::Manual;
use Data::Dumper;
use XML::Simple; #do this in findevent::manual or that here to avoid redundancy

sub new {
    my ($class, %args) = @_;

    my %options = (
        file => '',
        rawvideo => '',
        rawaudio => '',
        dovideo => '1',
        doaudio => '1',
        afps => '44100',
        vfps => '25',
        progid => '',
        writefile => '',      #write to file named
        writedb => '',        #write to db named
        progid => '',         #program id
        algoid => '',         #algorithm id
        genshell => '',       #generate shell script, don't actually copy frames
        actuallydo => '',     #copy appropriate frames; must specify sourcedir and destdir also
        sourcedir => '',      #copy video frames from
        destdir => '',        #copy video frames to

        resolution => '4',    #number of parts in a second
        desiredlength => '',  #0 gives longest possible
        verbose => '0',       #integer 0 (none) - 9 (all messages)
        );

    foreach my $option (keys %args) {
        warn __PACKAGE__ . ": unexpected: $option"
            if (not defined $options{$option});
        die __PACKAGE__ . ": must specify value as $option => value"
            if (not $args{$option});
        $options{$option} = $args{$option};
    }

    my $self = bless \%options, ref($class) || $class;
    foreach my $key (keys %options) {
        $self->{$key} = $options{$key};
    }
    #erm.
    $self->{'options'} = \%options;
    return $self;
}

sub check {
    # verify Video::FindEvent::* modules load without errors
    my ($self, $algorithms) = @_;
    ref($algorithms) eq 'HASH'
        or die __PACKAGE__ . ": error in algorithms hash";
    foreach my $algo (keys %$algorithms) {
        my $module = "Video::FindEvent::" . $algo;
        check_h($module);
    }
    return 1;
}

sub check_h {
    my ($module) = @_;
    eval { "require $module"; }
    #require $module
        or die __PACKAGE__ . ": problem with module $module";
    return 1;
}


sub use {
    my ($self, $algorithms) = @_;
    ref($algorithms) eq 'HASH'
        or die __PACKAGE__ . ": error in algorithms hash";

    foreach my $algo (keys %$algorithms) {
        foreach my $option (keys %{$self->{'options'}}) {
            $$algorithms{$algo}{$option} = $self->{'options'}{$option}
                if ($self->{'options'}{$option});
        }

        #make sure all is good with module, then require it
        my $module = "Video::FindEvent::" . $algo;
        check_h($module);
        eval { eval "require $module" } or die __PACKAGE__ . ": poof";

        #build new module with options present in algorithms hash
        $self->{'algo'}{$algo} = $module->new($$algorithms{$algo});
        my $refcl = ref($self->{'algo'}{$algo});
        ref($self->{'algo'}{$algo})
            or die __PACKAGE__ . ": problem with module $module constructor";
    }
    return 1;
}

sub findevents {
    my ($self, %args) = @_;

    #we only want to fork to run the event finding algorithms if we are
    #running more than one algorithm
    my $numberalgo = scalar values %{$self->{'algo'}};

    if ($numberalgo == 1) {
        foreach my $algo (values %{$self->{'algo'}}) {
        $algo->findevents(%args);
        }
    }
    else {
        foreach my $algo (values %{$self->{'algo'}}) {
            my $pid = fork;
            if (!$pid) {
                $algo->findevents(%args);
                exit 0;
            }
        }
    }
    return 1;
}

sub getbdys {
    my ($self) = @_;
    #X should not have to rebuild @events here
    my @events = $self->{'events'} ? @{$self->{'events'}}
                                   : @{$self->reconsevents()};
    my @bdys;
    foreach my $event (sort { $a->{'time'} <=> $b->{'time'} } @events) {
        push @bdys, $event->{'time'};
    }
    my @sorted = sort { $a <=> $b } @bdys;
    return \@sorted;
}

sub buildcool {
    my ($self, $length, $searchterm, @tags) = @_;
    my @events = $self->{'events'} ? @{$self->{'events'}}
                                   : @{$self->reconsevents()};
    my $last = $events[-1];
    unless ($length) {
        $length = $last->{'time'} if $last->{'time'};
        $length = $last->{'endtime'} if defined $last->{'endtime'};
    }

    my $resolution = $self->{'resolution'};
    my $desiredlength = $self->{'desiredlength'};

    my $cool = new Video::Function($resolution, $length);
    foreach my $event (@events) {
        if ($searchterm eq '-all') {
            $cool = $event->buildcool($cool, $length);
        }
        else {
            if ($event->matches($searchterm, @tags)) {
                $cool = $event->buildcool($cool, $length);
            }
        }
    }
    my $sum = $cool->sum();
    if ($self->{'verbose'} > 5) {
        print "sum: $sum\n";
        print "length: $length\n";
    }
    $desiredlength = $length unless $desiredlength;
    $cool->zero();
    $cool->compress($desiredlength, "simple");
    $cool->truncate();
    if ($self->{'verbose'} > 5) {
        print $cool->show();
    }
    return $cool;
}


sub extract {
    my ($self, $searchterm, @tag) = @_;
    my $length = 0; # means as long as necessary
    my $cool = $self->buildcool($length, $searchterm, @tag);

    #XXX these should be options
    my $dovideo = 1;
    my $doaudio = 0;

    $self->selectframes($cool, $dovideo, $doaudio, $self->{'vfps'}, $self->{'afps'});
    return 1;
}

sub match {
    my ($self, $event, $searchterm, @tags) = @_;
    return 1 unless $searchterm;
    return 1 unless @tags;
    my %hash = %$event;
    foreach my $key (keys %hash) {
        foreach my $tag (@tags) {
            if ($key eq $tag) {
                if ($searchterm eq $hash{$key}) {
                    return 1;
                }
                else {
                    return 0;
                }
            }
        }
    }
    return 0;
}

sub redefineenvl {
    #behaves like reconsevents, but reads in new config file
    my ($self, $newconfig) = @_;

    my @events = $self->{'events'} ? @{$self->{'events'}}
                                   : @{$self->reconsevents()};
    my $config = XMLin($newconfig,
                       keyattr => 'key',
                       forcearray => 0,
                       contentkey => '-command',
                       keeproot => 0,
                      );
    $config = Video::FindEvent::Manual::abusexml($config);


    foreach my $event (@events) {
        #match event against $config and reset envelope
        foreach my $key (%$config) {
            if ($event->{'name'} eq $$config{$key}{'name'}) {
                $event->{'envelope'} = $$config{$key}{'envl'};
                #do we want to change other properties too?
            }
        }
    }
    return \@events;
}


sub reconsevents {
    #this should talk to the database too.
    my ($self) = @_;

    if ($self->{'writefile'} ne '') {
        my $data = "";
        my $eventarray = $self->{'writefile'} . ".obj";
        #? do we always want to check config file for new envelopes?
        open FH, "+<$eventarray" or die "can't open $eventarray: $!";
        while () {
            $data .= $_;
        }
        $Data::Dump::Purity = 1;
        $Data::Dumper::Deepcopy = 1;
        my $ref = eval($data);
        $self->{'events'} = $ref if $ref;
        return $ref if $ref;
        die __PACKAGE__ . ": can't recons events";
    }
    if ($self->{'writedb'} ne '') {
        die __PACKAGE__ . ": sorry, not implemented.  Can't reconstruct events from database. Yet.";
    }

}

sub selectframes {
    #(this was compress.pl)
    #determine which frames to include in summary based on coolness function
    my ($self, $cool, $dovideo, $doaudio, $vfps, $afps) = @_;
    my $resolution = $cool->{'resolution'};
    my $length = $cool->{'length'};
    my $destdir = $self->{'destdir'};
    my $sourcedir = $self->{'sourcedir'};


    #add trailing / if necessary
    $sourcedir =~ s/(.*)/$1\// unless ($sourcedir =~ /^.*\/$/);
    $destdir =~ s/(.*)/$1\// unless ($destdir =~ /^.*\/$/);


    #number of video frames played in one second
    #used to calculate how many audio frames to play
    my $framecounter = 0;

    #counts total number of frames copied
    my $copiedframe = 0;

    #used to adjust volume over one second
    my $avecool = 0;  #over one second

    #XXX these should be options
    my $fileprefix = "frame";
    my $filesuffix = ".jpg";

    my $actuallydo = 0;
    $actuallydo = $self->{'actuallydo'} if $self->{'actuallydo'};
    my $genshell = 0;
    $genshell = $self->{'genshell'} if $self->{'genshell'};

    for (my $second=0; $second<$length; $second++) {
        $framecounter = 0;
        $avecool = 0;
        for (my $fraction=0; $fraction<1; $fraction+=(1/$resolution)) {
            my $vpnf = 0;
            $avecool = ${$cool->{'function'}}{$second+$fraction};
            for (my $vf=1; $vf<=($vfps/$resolution); $vf++) {
                #decide if we should play the next frame
                next if not defined ${$cool->{'function'}}{$second+$fraction};
                $vpnf += ${$cool->{'function'}}{$second+$fraction};
                if ($vpnf >= 1) {
                    my $framenumber = $second*$vfps +
                                      $fraction*$vfps +
                                      $vf;
                    $framenumber = sprintf("%09d", $framenumber);
                    $copiedframe = sprintf("%09d", $copiedframe);
                    my $infile = $fileprefix . $framenumber . $filesuffix;
                    my $outfile = $fileprefix . $copiedframe . $filesuffix;
                    my $command = "cp " . $sourcedir . $infile . " " . $destdir . $outfile;
                    system($command) if $actuallydo;
                    print "$command\n" if $genshell;
                    $vpnf--;
                    $framecounter++;
                    $copiedframe++;
                }
            }
        }
    }
}

1;