1# $Id: FilterList.pm 2287 2007-03-17 16:53:44Z joern $
2
3#-----------------------------------------------------------------------
4# Copyright (C) 2001-2006 J�rn Reder <joern AT zyn.de>.
5# All Rights Reserved. See file COPYRIGHT for details.
6#
7# This module is part of Video::DVDRip, which is free software; you can
8# redistribute it and/or modify it under the same terms as Perl itself.
9#-----------------------------------------------------------------------
10
11package Video::DVDRip::FilterList;
12use Locale::TextDomain qw (video.dvdrip);
13
14use base Video::DVDRip::Base;
15
16use Carp;
17use strict;
18use Data::Dumper;
19use FileHandle;
20
21use Video::DVDRip::CPAN::Scanf;
22
23my $DEBUG = 0;
24
25my $FILTER_LIST;
26my %FILTER_SELECTION_CB = (
27    logo => sub {
28        my %par = @_;
29        my ( $x1, $y1, $x2, $y2, $filter_setting )
30            = @par{ 'x1', 'y1', 'x2', 'y2', 'filter_setting' };
31
32        $filter_setting->set_value(
33            option_name => 'pos',
34            idx         => 0,
35            value       => $x1,
36        );
37
38        $filter_setting->set_value(
39            option_name => 'pos',
40            idx         => 1,
41            value       => $y1,
42        );
43
44        1;
45    },
46    logoaway => sub {
47        my %par = @_;
48        my ( $x1, $y1, $x2, $y2, $filter_setting )
49            = @par{ 'x1', 'y1', 'x2', 'y2', 'filter_setting' };
50
51        $filter_setting->set_value(
52            option_name => 'pos',
53            idx         => 0,
54            value       => $x1,
55        );
56
57        $filter_setting->set_value(
58            option_name => 'pos',
59            idx         => 1,
60            value       => $y1,
61        );
62
63        $filter_setting->set_value(
64            option_name => 'size',
65            idx         => 0,
66            value       => $x2 - $x1,
67        );
68
69        $filter_setting->set_value(
70            option_name => 'size',
71            idx         => 1,
72            value       => $y2 - $y1,
73        );
74
75        1;
76    },
77    mask => sub {
78        my %par = @_;
79        my ( $x1, $y1, $x2, $y2, $filter_setting )
80            = @par{ 'x1', 'y1', 'x2', 'y2', 'filter_setting' };
81
82        $filter_setting->set_value(
83            option_name => 'lefttop',
84            idx         => 0,
85            value       => $x1,
86        );
87
88        $filter_setting->set_value(
89            option_name => 'lefttop',
90            idx         => 1,
91            value       => $y1,
92        );
93
94        $filter_setting->set_value(
95            option_name => 'rightbot',
96            idx         => 0,
97            value       => $x2,
98        );
99
100        $filter_setting->set_value(
101            option_name => 'rightbot',
102            idx         => 1,
103            value       => $y2,
104        );
105
106        1;
107    },
108);
109
110sub filters			{ shift->{filters}			}
111sub set_filters			{ shift->{filters}		= $_[1]	}
112
113sub get_filter_list {
114    my $class = shift;
115
116    # cache instance per process
117    return $FILTER_LIST if $FILTER_LIST;
118
119    my $dir      = "$ENV{HOME}/.dvdrip";
120    my $filename = "$dir/tc_filter_list";
121
122    mkdir $dir, 0755 or die "can't create $dir" if not -d $dir;
123
124    my $transcode_modpath = qx[ tcmodinfo -p 2>/dev/null ];
125    chomp $transcode_modpath;
126
127    $DEBUG && print STDERR "transcode module path: $transcode_modpath\n";
128
129    # empty list if tcmodinfo not available
130    return $FILTER_LIST = $class->new() if not $transcode_modpath;
131
132    my $filter_mtime     = ( stat($filename) )[9];
133    my $transcode_mtime  = ( stat($transcode_modpath) )[9];
134    my $FilterList_mtime = (
135        stat(
136            $class->search_perl_inc(
137                rel_path => "Video/DVDRip/FilterList.pm"
138            )
139        )
140    )[9];
141
142    # create new list of no file avaiable or if file
143    # is older than transcode's modpath, or if dvd::rip's
144    # FilterList module is newer.
145    if (   not -f $filename
146        or $filter_mtime < $transcode_mtime
147        or $filter_mtime < $FilterList_mtime ) {
148        $FILTER_LIST = $class->new();
149        $FILTER_LIST->scan( modpath => $transcode_modpath );
150        $FILTER_LIST->save( filename => $filename );
151        return $FILTER_LIST;
152    }
153
154    return $FILTER_LIST = $class->load( filename => $filename );
155}
156
157sub new {
158    my $class = shift;
159
160    my $self = { filters => {}, };
161
162    return bless $self, $class;
163}
164
165sub load {
166    my $class      = shift;
167    my %par        = @_;
168    my ($filename) = @par{'filename'};
169
170    my $fh = FileHandle->new;
171    open( $fh, $filename ) or croak "can't read $filename";
172    my $data = join( '', <$fh> );
173    close $fh;
174
175    my $filter_list;
176    eval($data);
177    croak "can't load $filename. Perl error: $@" if $@;
178
179    return bless $filter_list, $class;
180}
181
182sub save {
183    my $self       = shift;
184    my %par        = @_;
185    my ($filename) = @par{'filename'};
186
187    my $data_sref = $self->get_save_data;
188
189    my $fh = FileHandle->new;
190
191    open( $fh, "> $filename" ) or confess "can't write $filename";
192    print $fh q{# $Id: FilterList.pm 2287 2007-03-17 16:53:44Z joern $},
193        "\n";
194    print $fh
195        "# This file was generated by Video::DVDRip Version $Video::DVDRip::VERSION\n\n";
196
197    print $fh ${$data_sref};
198    close $fh;
199
200    1;
201}
202
203sub get_save_data {
204    my $self = shift;
205
206    my $dd = Data::Dumper->new( [$self], ['filter_list'] );
207    $dd->Indent(1);
208    $dd->Purity(1);
209    my $data = $dd->Dump;
210
211    return \$data;
212}
213
214sub scan {
215    my $self      = shift;
216    my %par       = @_;
217    my ($modpath) = @par{'modpath'};
218
219    print STDERR
220        "[filterlist] (re)scanning transcode's module path $modpath...\n";
221
222    my @filter_names = grep !/^(pv|preview)$/,
223        map {m!/filter_([^/]+)\.so$/!} glob("$modpath/filter_*");
224
225    my %filters;
226    foreach my $filter_name (@filter_names) {
227        my $filter
228            = Video::DVDRip::Filter->new( filter_name => $filter_name );
229        next if !$filter || !$filter->capabilities;
230        $filters{$filter_name} = $filter;
231    }
232
233    $self->set_filters( \%filters );
234
235    1;
236}
237
238sub get_filter {
239    my $self          = shift;
240    my %par           = @_;
241    my ($filter_name) = @par{'filter_name'};
242
243    $self = $self->get_filter_list if not ref $self;
244
245    croak "Filter '$filter_name' unknown"
246        if not exists $self->filters->{$filter_name};
247
248    return $self->filters->{$filter_name};
249}
250
251package Video::DVDRip::Filter;
252use Locale::TextDomain qw (video.dvdrip);
253
254use Carp;
255use Text::Wrap;
256
257sub filter_name			{ shift->{filter_name}			}
258sub desc			{ shift->{desc}				}
259sub version			{ shift->{version}			}
260sub author			{ shift->{author}			}
261sub capabilities		{ shift->{capabilities}			}
262sub frames_needed		{ shift->{frames_needed}		}
263sub options			{ shift->{options}			}
264sub options_by_name		{ shift->{options_by_name}		}
265
266sub can_video			{ shift->capabilities =~ /V/ 		}
267sub can_audio			{ shift->capabilities =~ /A/ 		}
268sub can_rgb			{ shift->capabilities =~ /R/ 		}
269sub can_yuv			{ shift->capabilities =~ /Y/ 		}
270sub can_multiple		{ shift->capabilities =~ /M/ 		}
271
272sub is_pre			{ shift->capabilities =~ /E/ 		}
273sub is_post			{ shift->capabilities =~ /O/ 		}
274sub is_pre_post			{ $_[0]->is_pre and $_[0]->is_post	}
275
276sub new {
277    my $class         = shift;
278    my %par           = @_;
279    my ($filter_name) = @par{'filter_name'};
280
281    $DEBUG && print STDERR "Scan: tcmodinfo -i $filter_name ... ";
282
283    my $config;
284    eval {
285        local $SIG{ALRM} = sub { die "alarm" };
286        alarm 2;
287        $config = qx[ tcmodinfo -i $filter_name 2>/dev/null ];
288        alarm 0;
289    };
290
291    if ( $@ ) {
292        $DEBUG && print STDERR "TIMEOUT\n";
293        return;
294    }
295
296    $DEBUG && print STDERR "OK\n------\n$config\n------\n";
297
298    my $line;
299    my ( %options, @options );
300
301    my ( $desc, $version, $author, $capabilities, $frames_needed );
302    my $in_config = 0;
303
304    while ( $config =~ /(.*)/g ) {
305        $line = $1;
306        if ( not $in_config ) {
307            next if $line !~ /^START/;
308            $in_config = 1;
309        }
310        next if $line !~ /^"/;
311        if ( not $desc ) {
312            my @csv_fields = ( $line =~ /"([^"]+)"/g );
313            shift @csv_fields;
314            $desc          = shift @csv_fields;
315            $version       = shift @csv_fields;
316            $author        = shift @csv_fields;
317            $capabilities  = shift @csv_fields;
318            $frames_needed = shift @csv_fields;
319            next;
320        }
321
322        my $option = Video::DVDRip::FilterOption->new(
323            config      => $line,
324            filter_name => $filter_name,
325        );
326        return if $option->option_name !~ /^\w+$/;
327        $options{ $option->option_name } = $option;
328        push @options, $option;
329    }
330
331    $capabilities =~ s/O/E/ if $filter_name eq 'logoaway';
332
333    my $self = {
334        filter_name     => $filter_name,
335        desc            => $desc,
336        version         => $version,
337        author          => $author,
338        capabilities    => $capabilities,
339        frames_needed   => $frames_needed,
340        options         => \@options,
341        options_by_name => \%options,
342    };
343
344    return bless $self, $class;
345}
346
347sub get_option {
348    my $self          = shift;
349    my %par           = @_;
350    my ($option_name) = @par{'option_name'};
351
352    croak "Option '$option_name' unknown for filter '".$self->filter_name."'"
353        if not exists $self->options_by_name->{$option_name};
354
355    return $self->options_by_name->{$option_name};
356}
357
358sub get_info {
359    my $self = shift;
360
361    $Text::Wrap::columns = 32;
362
363    my @info = (
364        [ "Name",      wrap( "", "", $self->filter_name ), ],
365        [ "Desc",      wrap( "", "", $self->desc ), ],
366        [ "Version",   wrap( "", "", $self->version ), ],
367        [ "Author(s)", wrap( "", "", $self->author ), ],
368    );
369
370    my $info;
371    $info .= "Video, " if $self->can_video;
372    $info .= "Audio, " if $self->can_audio;
373    $info =~ s/, $//;
374
375    push @info, [ "Type", $info ];
376
377    $info = "";
378    $info .= "RGB, " if $self->can_rgb;
379    $info .= "YUV, " if $self->can_yuv;
380    $info =~ s/, $//;
381
382    push @info, [ "Color", $info ];
383
384    $info = "";
385    $info .= "PRE, "  if $self->is_pre;
386    $info .= "POST, " if $self->is_post;
387    $info =~ s/, $//;
388    $info ||= "unknown";
389
390    push @info, [ "Pre/Post", $info ];
391    push @info, [ "Multiple", ( $self->can_multiple ? "Yes" : "No" ) ];
392
393    return \@info;
394}
395
396sub av_type {
397    my $self = shift;
398
399    my $info = "";
400    $info .= __("Video").", " if $self->can_video;
401    $info .= __("Audio").", " if $self->can_audio;
402    $info =~ s/, $//;
403
404    return $info;
405}
406
407sub colorspace_type {
408    my $self = shift;
409
410    return "--" if !$self->can_video;
411
412    my $info = "";
413    $info .= "RGB, " if $self->can_rgb;
414    $info .= "YUV, " if $self->can_yuv;
415    $info =~ s/, $//;
416
417    return $info;
418}
419
420sub pre_post_type {
421    my $self = shift;
422
423    my $info = "";
424    $info .= "PRE, "  if $self->is_pre;
425    $info .= "POST, " if $self->is_post;
426    $info =~ s/, $//;
427    $info ||= "unknown";
428
429    return $info;
430}
431
432sub multiple_type {
433    my $self = shift;
434    return $self->can_multiple ? __"Yes" : __"No";
435}
436
437sub get_selection_cb {
438    my $self = shift;
439
440    return $FILTER_SELECTION_CB{ $self->filter_name };
441}
442
443sub get_dummy_instance {
444    my $self = shift;
445    return Video::DVDRip::FilterSettingsInstance->new (
446        id          => -1,
447        filter_name => $self->filter_name
448    );
449}
450
451package Video::DVDRip::FilterOption;
452use Locale::TextDomain qw (video.dvdrip);
453
454use Carp;
455use Text::Wrap;
456
457sub option_name			{ shift->{option_name}			}
458sub desc			{ shift->{desc}				}
459sub format			{ shift->{format}			}
460sub fields			{ shift->{fields}			}
461sub switch			{ shift->{switch}			}
462
463sub new {
464    my $class = shift;
465    my %par   = @_;
466    my ( $config, $filter_name ) = @par{ 'config', 'filter_name' };
467
468    my @csv_fields = ( $config =~ /"([^"]*)"/g );
469
470    my $name    = shift @csv_fields;
471    my $desc    = shift @csv_fields;
472    my $format  = shift @csv_fields;
473    my $default = shift @csv_fields;
474
475    my $switch;
476    if ( $format eq '' ) {
477
478        # on/off only, no value
479        push @csv_fields, "0", "1";
480        $format = "%B";
481        $switch = 1;
482    }
483    elsif ( $format eq '%s' ) {
484        push @csv_fields, "", "";
485    }
486
487    # cpaudio reports '%c' - stupid, %c scans ASCII code
488    $format = '%s' if $format eq '%c';
489
490    # logoaway reports '%2x' - stupid, we get spaces this way
491    $format =~ s/\%2x/\%02x/g;
492
493    my $scan_format = $format;
494    $scan_format =~ s/\%\%//g;    # eliminate quoted %
495    my $default_format = $format;
496    $default_format =~ s/\%\%//g;    # eliminate quoted %
497
498    my @field_formats = ( $scan_format =~ /\%(.)/g );
499    my @default_values
500        = Video::DVDRip::CPAN::Scanf::sscanf( $default_format, $default );
501
502    my @fields;
503    while (@csv_fields) {
504        my $range_from = shift @csv_fields;
505        my $range_to   = shift @csv_fields;
506        my $type       = shift @field_formats;
507
508        push @fields,
509            Video::DVDRip::FilterOptionField->new(
510                default    => shift @default_values,
511                range_from => $range_from,
512                range_to   => $range_to,
513                fractional => ( $type eq 'f' ),
514                text       => ( $type eq 's' ),
515            );
516    }
517
518    print "WARNING: [$filter_name] Option $name has fields left!\n"
519        if @default_values;
520
521    my $self = {
522        option_name => $name,
523        desc        => $desc,
524        format      => $format,
525        fields      => \@fields,
526        switch      => $switch,
527    };
528
529    return bless $self, $class;
530}
531
532sub get_wrapped_desc {
533    my $self = shift;
534
535    local($Text::Wrap::columns) = 24;
536
537    return join( "\n", wrap( "", "", $self->desc ) );
538}
539
540package Video::DVDRip::FilterOptionField;
541use Locale::TextDomain qw (video.dvdrip);
542
543sub default			{ shift->{default}			}
544sub range_from			{ shift->{range_from}			}
545sub range_to			{ shift->{range_to}			}
546sub fractional			{ shift->{fractional}			}
547sub switch			{ shift->{switch}			}
548sub checkbox			{ shift->{checkbox}			}
549sub combo			{ shift->{combo}			}
550sub text			{ shift->{text}				}
551
552#-----------------------------------------------------------
553# checkbox vs. switch
554# ===================
555#
556# Both are checkboxes on the GUI, but the internal
557# parameter code generation differs:
558#
559# switch: the parameter has no option value. It's there or
560# 	  it's not there.
561#
562# checkbox: the parameter has either 0 or 1 as option value.
563#-----------------------------------------------------------
564
565sub new {
566    my $class = shift;
567    my %par = @_;
568    my  ($default, $range_from, $range_to, $fractional, $switch) =
569    @par{'default','range_from','range_to','fractional','switch'};
570    my  ($text) =
571    @par{'text'};
572
573    my ( $checkbox, $combo );
574
575    $range_to = undef
576        if $range_to eq 'oo'
577        or $range_to < $range_from;
578
579    $range_from = -99999999
580        if $range_from eq ''
581        or $range_from =~ /\D/;
582
583    $range_to = 99999999
584        if $range_to eq ''
585        or $range_to =~ /\D/;
586
587    if ( not $fractional and $range_from !~ /\D/ and $range_to !~ /\D/ ) {
588        if ( $range_from == 0 and $range_to == 1 ) {
589            $checkbox = 1;
590        }
591        elsif ( $range_to ne ''
592            and $range_from ne ''
593            and $range_to - $range_from < 20 ) {
594            $combo = 1;
595        }
596    }
597
598    my $self = {
599        default    => $default,
600        range_from => $range_from,
601        range_to   => $range_to,
602        fractional => $fractional,
603        switch     => $switch,
604        checkbox   => $checkbox,
605        combo      => $combo,
606        text       => $text,
607    };
608
609    return bless $self, $class;
610}
611
612sub get_range_text {
613    my $self = shift;
614
615    return "Default: " . ( $self->default ? "on" : "off" )
616        if $self->checkbox
617        or $self->switch;
618    return "Default: " . $self->default if $self->text;
619
620    my $frac = $self->fractional ? " (fractional)" : "";
621
622    my $range_from = $self->range_from;
623    my $range_to   = $self->range_to;
624
625    foreach my $range ( $range_from, $range_to ) {
626        $range = "WIDTH"  if $range eq 'W' or $range eq 'width';
627        $range = "HEIGHT" if $range eq 'H' or $range eq 'height';
628    }
629
630    $range_from = "-oo" if $range_from == -99999999;
631    $range_to   = "oo"  if $range_to == 99999999;
632
633    my $default = $self->default;
634    $default = "<empty>" if $default eq '';
635
636    my $info = "Valid values$frac: $range_from .. $range_to "
637        . "(Default: $default)";
638
639    return $info;
640}
641
6421;
643