File Coverage

blib/lib/Video/DVDRip/FilterList.pm

Criterion	Covered	Total	%
statement	42	298	14.0
branch	0	114	0.0
condition	0	48	0.0
subroutine	14	66	21.2
pod	0	9	0.0
total	56	535	10.4

# $Id: FilterList.pm 2287 2007-03-17 16:53:44Z joern $

#-----------------------------------------------------------------------
# Copyright (C) 2001-2006 Jörn Reder .
# All Rights Reserved. See file COPYRIGHT for details.
#
# This module is part of Video::DVDRip, which is free software; you can
# redistribute it and/or modify it under the same terms as Perl itself.
#-----------------------------------------------------------------------

package Video::DVDRip::FilterList;
use Locale::TextDomain qw (video.dvdrip);

use base Video::DVDRip::Base;

use Carp;
use strict;
use Data::Dumper;
use FileHandle;

use Video::DVDRip::CPAN::Scanf;

my $DEBUG = 0;

my $FILTER_LIST;
my %FILTER_SELECTION_CB = (
    logo => sub {
        my %par = @_;
        my ( $x1, $y1, $x2, $y2, $filter_setting )
            = @par{ 'x1', 'y1', 'x2', 'y2', 'filter_setting' };

        $filter_setting->set_value(
            option_name => 'pos',
            idx         => 0,
            value       => $x1,
        );

        $filter_setting->set_value(
            option_name => 'pos',
            idx         => 1,
            value       => $y1,
        );

        1;
    },
    logoaway => sub {
        my %par = @_;
        my ( $x1, $y1, $x2, $y2, $filter_setting )
            = @par{ 'x1', 'y1', 'x2', 'y2', 'filter_setting' };

        $filter_setting->set_value(
            option_name => 'pos',
            idx         => 0,
            value       => $x1,
        );

        $filter_setting->set_value(
            option_name => 'pos',
            idx         => 1,
            value       => $y1,
        );

        $filter_setting->set_value(
            option_name => 'size',
            idx         => 0,
            value       => $x2 - $x1,
        );

        $filter_setting->set_value(
            option_name => 'size',
            idx         => 1,
            value       => $y2 - $y1,
        );

        1;
    },
    mask => sub {
        my %par = @_;
        my ( $x1, $y1, $x2, $y2, $filter_setting )
            = @par{ 'x1', 'y1', 'x2', 'y2', 'filter_setting' };

        $filter_setting->set_value(
            option_name => 'lefttop',
            idx         => 0,
            value       => $x1,
        );

        $filter_setting->set_value(
            option_name => 'lefttop',
            idx         => 1,
            value       => $y1,
        );

        $filter_setting->set_value(
            option_name => 'rightbot',
            idx         => 0,
            value       => $x2,
        );

        $filter_setting->set_value(
            option_name => 'rightbot',
            idx         => 1,
            value       => $y2,
        );

        1;
    },
);

sub filters			{ shift->{filters}			}
sub set_filters			{ shift->{filters}		= $_[1]	}

sub get_filter_list {
    my $class = shift;

    # cache instance per process
    return $FILTER_LIST if $FILTER_LIST;

    my $dir      = "$ENV{HOME}/.dvdrip";
    my $filename = "$dir/tc_filter_list";

    mkdir $dir, 0755 or die "can't create $dir" if not -d $dir;

    my $transcode_modpath = qx[ tcmodinfo -p 2>/dev/null ];
    chomp $transcode_modpath;

    $DEBUG && print STDERR "transcode module path: $transcode_modpath\n";

    # empty list if tcmodinfo not available
    return $FILTER_LIST = $class->new() if not $transcode_modpath;

    my $filter_mtime     = ( stat($filename) )[9];
    my $transcode_mtime  = ( stat($transcode_modpath) )[9];
    my $FilterList_mtime = (
        stat(
            $class->search_perl_inc(
                rel_path => "Video/DVDRip/FilterList.pm"
            )
        )
    )[9];

    # create new list of no file avaiable or if file
    # is older than transcode's modpath, or if dvd::rip's
    # FilterList module is newer.
    if (   not -f $filename
        or $filter_mtime < $transcode_mtime
        or $filter_mtime < $FilterList_mtime ) {
        $FILTER_LIST = $class->new();
        $FILTER_LIST->scan( modpath => $transcode_modpath );
        $FILTER_LIST->save( filename => $filename );
        return $FILTER_LIST;
    }

    return $FILTER_LIST = $class->load( filename => $filename );
}

sub new {
    my $class = shift;

    my $self = { filters => {}, };

    return bless $self, $class;
}

sub load {
    my $class      = shift;
    my %par        = @_;
    my ($filename) = @par{'filename'};

    my $fh = FileHandle->new;
    open( $fh, $filename ) or croak "can't read $filename";
    my $data = join( '', <$fh> );
    close $fh;

    my $filter_list;
    eval($data);
    croak "can't load $filename. Perl error: $@" if $@;

    return bless $filter_list, $class;
}

sub save {
    my $self       = shift;
    my %par        = @_;
    my ($filename) = @par{'filename'};

    my $data_sref = $self->get_save_data;

    my $fh = FileHandle->new;

    open( $fh, "> $filename" ) or confess "can't write $filename";
    print $fh q{# $Id: FilterList.pm 2287 2007-03-17 16:53:44Z joern $},
        "\n";
    print $fh
        "# This file was generated by Video::DVDRip Version $Video::DVDRip::VERSION\n\n";

    print $fh ${$data_sref};
    close $fh;

    1;
}

sub get_save_data {
    my $self = shift;

    my $dd = Data::Dumper->new( [$self], ['filter_list'] );
    $dd->Indent(1);
    $dd->Purity(1);
    my $data = $dd->Dump;

    return \$data;
}

sub scan {
    my $self      = shift;
    my %par       = @_;
    my ($modpath) = @par{'modpath'};

    print STDERR
        "[filterlist] (re)scanning transcode's module path $modpath...\n";

    my @filter_names = grep !/^(pv|preview)$/,
        map {m!/filter_([^/]+)\.so$!} glob("$modpath/filter_*");

    my %filters;
    foreach my $filter_name (@filter_names) {
        my $filter
            = Video::DVDRip::Filter->new( filter_name => $filter_name );
        next if !$filter || !$filter->capabilities;
        $filters{$filter_name} = $filter;
    }

    $self->set_filters( \%filters );

    1;
}

sub get_filter {
    my $self          = shift;
    my %par           = @_;
    my ($filter_name) = @par{'filter_name'};

    $self = $self->get_filter_list if not ref $self;

    croak "Filter '$filter_name' unknown"
        if not exists $self->filters->{$filter_name};

    return $self->filters->{$filter_name};
}

package Video::DVDRip::Filter;
use Locale::TextDomain qw (video.dvdrip);

use Carp;
use Text::Wrap;

sub filter_name			{ shift->{filter_name}			}
sub desc			{ shift->{desc}				}
sub version			{ shift->{version}			}
sub author			{ shift->{author}			}
sub capabilities		{ shift->{capabilities}			}
sub frames_needed		{ shift->{frames_needed}		}
sub options			{ shift->{options}			}
sub options_by_name		{ shift->{options_by_name}		}

sub can_video			{ shift->capabilities =~ /V/ 		}
sub can_audio			{ shift->capabilities =~ /A/ 		}
sub can_rgb			{ shift->capabilities =~ /R/ 		}
sub can_yuv			{ shift->capabilities =~ /Y/ 		}
sub can_multiple		{ shift->capabilities =~ /M/ 		}

sub is_pre			{ shift->capabilities =~ /E/ 		}
sub is_post			{ shift->capabilities =~ /O/ 		}
sub is_pre_post			{ $_[0]->is_pre and $_[0]->is_post	}

sub new {
    my $class         = shift;
    my %par           = @_;
    my ($filter_name) = @par{'filter_name'};

    $DEBUG && print STDERR "Scan: tcmodinfo -i $filter_name ... ";

    my $config;
    eval {
        local $SIG{ALRM} = sub { die "alarm" };
        alarm 2;
        $config = qx[ tcmodinfo -i $filter_name 2>/dev/null ];
        alarm 0;
    };

    if ( $@ ) {
        $DEBUG && print STDERR "TIMEOUT\n";
        return;
    }

    $DEBUG && print STDERR "OK\n------\n$config\n------\n";

    my $line;
    my ( %options, @options );

    my ( $desc, $version, $author, $capabilities, $frames_needed );
    my $in_config = 0;

    while ( $config =~ /(.*)/g ) {
        $line = $1;
        if ( not $in_config ) {
            next if $line !~ /^START/;
            $in_config = 1;
        }
        next if $line !~ /^"/;
        if ( not $desc ) {
            my @csv_fields = ( $line =~ /"([^"]+)"/g );
            shift @csv_fields;
            $desc          = shift @csv_fields;
            $version       = shift @csv_fields;
            $author        = shift @csv_fields;
            $capabilities  = shift @csv_fields;
            $frames_needed = shift @csv_fields;
            next;
        }

        my $option = Video::DVDRip::FilterOption->new(
            config      => $line,
            filter_name => $filter_name,
        );
        return if $option->option_name !~ /^\w+$/;
        $options{ $option->option_name } = $option;
        push @options, $option;
    }

    $capabilities =~ s/O/E/ if $filter_name eq 'logoaway';

    my $self = {
        filter_name     => $filter_name,
        desc            => $desc,
        version         => $version,
        author          => $author,
        capabilities    => $capabilities,
        frames_needed   => $frames_needed,
        options         => \@options,
        options_by_name => \%options,
    };

    return bless $self, $class;
}

sub get_option {
    my $self          = shift;
    my %par           = @_;
    my ($option_name) = @par{'option_name'};

    croak "Option '$option_name' unknown for filter '".$self->filter_name."'"
        if not exists $self->options_by_name->{$option_name};

    return $self->options_by_name->{$option_name};
}

sub get_info {
    my $self = shift;

    $Text::Wrap::columns = 32;

    my @info = (
        [ "Name",      wrap( "", "", $self->filter_name ), ],
        [ "Desc",      wrap( "", "", $self->desc ), ],
        [ "Version",   wrap( "", "", $self->version ), ],
        [ "Author(s)", wrap( "", "", $self->author ), ],
    );

    my $info;
    $info .= "Video, " if $self->can_video;
    $info .= "Audio, " if $self->can_audio;
    $info =~ s/, $//;

    push @info, [ "Type", $info ];

    $info = "";
    $info .= "RGB, " if $self->can_rgb;
    $info .= "YUV, " if $self->can_yuv;
    $info =~ s/, $//;

    push @info, [ "Color", $info ];

    $info = "";
    $info .= "PRE, "  if $self->is_pre;
    $info .= "POST, " if $self->is_post;
    $info =~ s/, $//;
    $info ||= "unknown";

    push @info, [ "Pre/Post", $info ];
    push @info, [ "Multiple", ( $self->can_multiple ? "Yes" : "No" ) ];

    return \@info;
}

sub av_type {
    my $self = shift;

    my $info = "";
    $info .= __("Video").", " if $self->can_video;
    $info .= __("Audio").", " if $self->can_audio;
    $info =~ s/, $//;

    return $info;
}

sub colorspace_type {
    my $self = shift;

    return "--" if !$self->can_video;

    my $info = "";
    $info .= "RGB, " if $self->can_rgb;
    $info .= "YUV, " if $self->can_yuv;
    $info =~ s/, $//;

    return $info;
}

sub pre_post_type {
    my $self = shift;

    my $info = "";
    $info .= "PRE, "  if $self->is_pre;
    $info .= "POST, " if $self->is_post;
    $info =~ s/, $//;
    $info ||= "unknown";

    return $info;
}

sub multiple_type {
    my $self = shift;
    return $self->can_multiple ? __"Yes" : __"No";
}

sub get_selection_cb {
    my $self = shift;

    return $FILTER_SELECTION_CB{ $self->filter_name };
}

sub get_dummy_instance {
    my $self = shift;
    return Video::DVDRip::FilterSettingsInstance->new (
        id          => -1,
        filter_name => $self->filter_name
    );
}

package Video::DVDRip::FilterOption;
use Locale::TextDomain qw (video.dvdrip);

use Carp;
use Text::Wrap;

sub option_name			{ shift->{option_name}			}
sub desc			{ shift->{desc}				}
sub format			{ shift->{format}			}
sub fields			{ shift->{fields}			}
sub switch			{ shift->{switch}			}

sub new {
    my $class = shift;
    my %par   = @_;
    my ( $config, $filter_name ) = @par{ 'config', 'filter_name' };

    my @csv_fields = ( $config =~ /"([^"]*)"/g );

    my $name    = shift @csv_fields;
    my $desc    = shift @csv_fields;
    my $format  = shift @csv_fields;
    my $default = shift @csv_fields;

    my $switch;
    if ( $format eq '' ) {

        # on/off only, no value
        push @csv_fields, "0", "1";
        $format = "%B";
        $switch = 1;
    }
    elsif ( $format eq '%s' ) {
        push @csv_fields, "", "";
    }

    # cpaudio reports '%c' - stupid, %c scans ASCII code
    $format = '%s' if $format eq '%c';

    # logoaway reports '%2x' - stupid, we get spaces this way
    $format =~ s/\%2x/\%02x/g;

    my $scan_format = $format;
    $scan_format =~ s/\%\%//g;    # eliminate quoted %
    my $default_format = $format;
    $default_format =~ s/\%\%//g;    # eliminate quoted %

    my @field_formats = ( $scan_format =~ /\%(.)/g );
    my @default_values
        = Video::DVDRip::CPAN::Scanf::sscanf( $default_format, $default );

    my @fields;
    while (@csv_fields) {
        my $range_from = shift @csv_fields;
        my $range_to   = shift @csv_fields;
        my $type       = shift @field_formats;

        push @fields,
            Video::DVDRip::FilterOptionField->new(
                default    => shift @default_values,
                range_from => $range_from,
                range_to   => $range_to,
                fractional => ( $type eq 'f' ),
                text       => ( $type eq 's' ),
            );
    }

    print "WARNING: [$filter_name] Option $name has fields left!\n"
        if @default_values;

    my $self = {
        option_name => $name,
        desc        => $desc,
        format      => $format,
        fields      => \@fields,
        switch      => $switch,
    };

    return bless $self, $class;
}

sub get_wrapped_desc {
    my $self = shift;

    local($Text::Wrap::columns) = 24;

    return join( "\n", wrap( "", "", $self->desc ) );
}

package Video::DVDRip::FilterOptionField;
use Locale::TextDomain qw (video.dvdrip);

sub default			{ shift->{default}			}
sub range_from			{ shift->{range_from}			}
sub range_to			{ shift->{range_to}			}
sub fractional			{ shift->{fractional}			}
sub switch			{ shift->{switch}			}
sub checkbox			{ shift->{checkbox}			}
sub combo			{ shift->{combo}			}
sub text			{ shift->{text}				}

#-----------------------------------------------------------
# checkbox vs. switch
# ===================
#
# Both are checkboxes on the GUI, but the internal
# parameter code generation differs:
#
# switch: the parameter has no option value. It's there or
# 	  it's not there.
#
# checkbox: the parameter has either 0 or 1 as option value.
#-----------------------------------------------------------

sub new {
    my $class = shift;
    my %par = @_;
    my  ($default, $range_from, $range_to, $fractional, $switch) =
    @par{'default','range_from','range_to','fractional','switch'};
    my  ($text) =
    @par{'text'};

    my ( $checkbox, $combo );

    $range_to = undef
        if $range_to eq 'oo'
        or $range_to < $range_from;

    $range_from = -99999999
        if $range_from eq ''
        or $range_from =~ /\D/;

    $range_to = 99999999
        if $range_to eq ''
        or $range_to =~ /\D/;

    if ( not $fractional and $range_from !~ /\D/ and $range_to !~ /\D/ ) {
        if ( $range_from == 0 and $range_to == 1 ) {
            $checkbox = 1;
        }
        elsif ( $range_to ne ''
            and $range_from ne ''
            and $range_to - $range_from < 20 ) {
            $combo = 1;
        }
    }

    my $self = {
        default    => $default,
        range_from => $range_from,
        range_to   => $range_to,
        fractional => $fractional,
        switch     => $switch,
        checkbox   => $checkbox,
        combo      => $combo,
        text       => $text,
    };

    return bless $self, $class;
}

sub get_range_text {
    my $self = shift;

    return "Default: " . ( $self->default ? "on" : "off" )
        if $self->checkbox
        or $self->switch;
    return "Default: " . $self->default if $self->text;

    my $frac = $self->fractional ? " (fractional)" : "";

    my $range_from = $self->range_from;
    my $range_to   = $self->range_to;

    foreach my $range ( $range_from, $range_to ) {
        $range = "WIDTH"  if $range eq 'W' or $range eq 'width';
        $range = "HEIGHT" if $range eq 'H' or $range eq 'height';
    }

    $range_from = "-oo" if $range_from == -99999999;
    $range_to   = "oo"  if $range_to == 99999999;

    my $default = $self->default;
    $default = "" if $default eq '';

    my $info = "Valid values$frac: $range_from .. $range_to "
        . "(Default: $default)";

    return $info;
}

1;