1# $Id: Base.pm 2280 2007-03-17 10:56:47Z 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::Base;
12use Locale::TextDomain qw (video.dvdrip);
13
14use Video::DVDRip::Config;
15use Video::DVDRip::FilterList;
16
17use Carp;
18use strict;
19use FileHandle;
20use IO::Pipe;
21use Fcntl;
22use Data::Dumper;
23
24# load preferences ---------------------------------------------------
25my $CONFIG_OBJECT = Video::DVDRip::Config->new;
26$Video::DVDRip::PREFERENCE_FILE ||= "$ENV{HOME}/.dvdriprc";
27$CONFIG_OBJECT->set_filename($Video::DVDRip::PREFERENCE_FILE);
28$CONFIG_OBJECT->save if not -f $Video::DVDRip::PREFERENCE_FILE;
29$CONFIG_OBJECT->load;
30
31# detect installed tool versions -------------------------------------
32require Video::DVDRip::Depend;
33my $DEPEND_OBJECT = Video::DVDRip::Depend->new;
34
35# pre load transcode's filter list -----------------------------------
36Video::DVDRip::FilterList->get_filter_list
37    if $DEPEND_OBJECT->version("transcode") >= 603;
38
39# init some config settings ------------------------------------------
40# (this depends on a loaded Config and Depend, that's why we call it here)
41$CONFIG_OBJECT->init_settings;
42
43sub new {
44    my $class = shift;
45    return bless {}, $class;
46}
47
48sub config {
49    my $thingy = shift;
50    my ($name) = @_;
51    return $CONFIG_OBJECT->get_value($name);
52}
53
54sub set_config {
55    my $thingy = shift;
56    my ( $name, $value ) = @_;
57    $CONFIG_OBJECT->set_value( $name, $value );
58    return $value;
59}
60
61sub config_object {
62    $CONFIG_OBJECT;
63}
64
65sub depend_object {
66    $DEPEND_OBJECT;
67}
68
69sub has {
70    my $self = shift;
71    my ($command) = @_;
72
73    return $self->depend_object->has($command);
74}
75
76sub exists {
77    my $self = shift;
78    my ($command) = @_;
79
80    return $self->depend_object->exists($command);
81}
82
83sub version {
84    my $self = shift;
85    my ($command) = @_;
86
87    return $self->depend_object->version($command);
88}
89
90sub debug_level { $Video::DVDRip::DEBUG || shift->{debug_level} }
91
92sub set_debug_level {
93    my $thing = shift;
94    my $debug;
95    if ( ref $thing ) {
96        $thing->{debug_level} = shift if @_;
97        $debug = $thing->{debug_level};
98    }
99    else {
100        $Video::DVDRip::DEBUG = shift if @_;
101        $debug = $Video::DVDRip::DEBUG;
102    }
103
104    if ($debug) {
105        $Video::DVDRip::DEBUG::TIME = scalar( localtime(time) );
106        print STDERR "--- START ------------------------------------\n",
107            "$$: $Video::DVDRip::DEBUG::TIME - DEBUG LEVEL $debug\n";
108    }
109
110    return $debug;
111}
112
113sub dump {
114    my $self = shift;
115    push @_, $self if not @_;
116
117    my $dd = Data::Dumper->new( \@_ );
118    $dd->Indent(1);
119    print $dd->Dump;
120
121    1;
122}
123
124sub print_debug {
125    my $self = shift;
126
127    my $debug = $Video::DVDRip::DEBUG;
128    $debug = $self->{debug_level} if ref $self and $self->{debug_level};
129
130    if ($debug) {
131        print STDERR join( "\n", @_ ), "\n";
132    }
133
134    1;
135}
136
137sub system {
138    my $self = shift;
139    my %par  = @_;
140    my ( $command, $err_ignore, $return_rc )
141        = @par{ 'command', 'err_ignore', 'return_rc' };
142
143    $self->log("Executing command: $command");
144
145    $self->print_debug("executing command: $command");
146
147    my $catch = `($command) 2>&1`;
148    my $rc    = $?;
149
150    $self->print_debug("got: rc=$rc catch=$catch");
151
152    croak "Error executing command $command:\n$catch" if $rc;
153
154    return $return_rc ? $? : $catch;
155}
156
157sub popen {
158    my $self = shift;
159    my %par  = @_;
160    my ( $command, $callback ) = @par{ 'command', 'callback' };
161
162    return $self->popen_with_callback(@_) if $callback;
163
164    $self->print_debug("executing command: $command");
165    $self->log("Executing command: $command");
166
167    my $fh = FileHandle->new;
168    open( $fh, "($command) 2>&1 |" )
169        or croak "can't fork $command";
170
171    my $flags = '';
172    fcntl( $fh, F_GETFL, $flags )
173        or die "Can't get flags: $!\n";
174    $flags |= O_NONBLOCK;
175    fcntl( $fh, F_SETFL, $flags )
176        or die "Can't set flags: $!\n";
177
178    return $fh;
179}
180
181sub popen_with_callback {
182    my $self = shift;
183    my %par  = @_;
184    my ( $command, $callback, $catch_output )
185        = @par{ 'command', 'callback', 'catch_output' };
186
187    $self->print_debug("executing command: $command");
188    $self->log("Executing command: $command");
189
190    my $fh = FileHandle->new;
191    open( $fh, "($command) 2>&1 |" )
192        or croak "can't fork $command";
193    select $fh;
194    $| = 1;
195    select STDOUT;
196    return $fh if not $callback;
197
198    my ( $output, $buffer );
199    while ( read( $fh, $buffer, 512 ) ) {
200        &$callback($buffer);
201        $output .= $_ if $catch_output;
202    }
203
204    close $fh;
205
206    return $output;
207}
208
209sub format_time {
210    my $self   = shift;
211    my %par    = @_;
212    my ($time) = @par{'time'};
213
214    my ( $h, $m, $s );
215    $h = int( $time / 3600 );
216    $m = int( ( $time - $h * 3600 ) / 60 );
217    $s = $time % 60;
218
219    return sprintf( "%02d:%02d:%02d", $h, $m, $s );
220}
221
222sub stripped_exception {
223    my $text = $@;
224    $text =~ s/\s+at\s+[^\s]+\s+line\s+\d+\.?//;
225    $text =~ s/^msg:\s*//;
226    return $text;
227}
228
229my $logger;
230
231sub logger {$logger}
232
233sub set_logger {
234    my $self = shift;
235    my ($set_logger) = @_;
236    return $logger = $set_logger;
237}
238
239sub log {
240    shift;
241    return if not defined $logger;
242    $logger->log(@_);
243    1;
244}
245
246sub clone {
247    my $self = shift;
248
249    require Storable;
250    return Storable::dclone($self);
251}
252
253sub combine_command_options {
254    my $self = shift;
255    my %par  = @_;
256    my ( $cmd, $cmd_line, $options ) = @par{ 'cmd', 'cmd_line', 'options' };
257
258    # split command line into separate commands
259    $cmd_line =~ s/\s+$//;
260    $cmd_line .= ";" if $cmd_line !~ /;$/;
261    my @parts = grep !/^$/,
262        ( $cmd_line
263            =~ m!(.*?)\s*(\(|\)|;|&&|\|\||\`which nice\`\s+-n\s+[\d-]+|execflow\s+(?:-n\s*\d+)?)\s*!g
264        );
265    # walk through and process requested command
266    foreach my $part (@parts) {
267        next if $part !~ s/^$cmd\s+//;
268        my $options_href
269            = $self->get_shell_options( options => $part . " " . $options );
270        $part = "$cmd " . join( " ", values %{$options_href} );
271    }
272
273    # remove trailing semicolon
274    pop @parts;
275
276    # join parts and return
277    $cmd = join( " ", @parts );
278
279    return $cmd;
280}
281
282sub get_shell_options {
283    my $self      = shift;
284    my %par       = @_;
285    my ($options) = @par{'options'};
286
287    my %options;
288    my @words = map { /\s/ ? "'$_'" : $_ } $self->get_shell_words($options);
289
290    my $opt;
291    for ( my $i = 0; $i < @words; ++$i ) {
292        $words[$i] = "'$words[$i]'" if $words[$i] =~ /\s/;
293        if ( $words[$i] =~ /^(-+\D.*)/ ) {
294
295            # why \D? Answer: minus followed by a number is
296            # surley a value, no option.
297            $opt = $1;
298            if ( $i + 1 != @words and $words[ $i + 1 ] !~ /^-/ ) {
299                $options{$opt} = "$opt $words[$i+1]";
300                ++$i;
301            }
302            else {
303                $options{$opt} = "$opt";
304            }
305        }
306        else {
307            $options{$opt} .= " " . $words[$i];
308        }
309    }
310
311    return \%options;
312}
313
314# This subroutine is taken from "shellwords.pl" (standard Perl
315# library) and slightly modified (mainly usage of lexical
316# variables instead of globals).
317
318sub get_shell_words {
319    my $thing = shift;
320
321    local ($_) = join( '', @_ ) if @_;
322
323    my ( @words, $snippet, $field );
324
325    s/^\s+//;
326    while ( $_ ne '' ) {
327        $field = '';
328        for ( ;; ) {
329            if (s/^"(([^"\\]|\\.)*)"//) {
330                ( $snippet = $1 ) =~ s#\\(.)#$1#g;
331            }
332            elsif (/^"/) {
333                die "Unmatched double quote: $_\n";
334            }
335            elsif (s/^'(([^'\\]|\\.)*)'//) {
336                ( $snippet = $1 ) =~ s#\\(.)#$1#g;
337            }
338            elsif (/^'/) {
339                die "Unmatched single quote: $_\n";
340            }
341            elsif (s/^\\(.)//) {
342                $snippet = $1;
343            }
344            elsif (s/^([^\s\\'"]+)//) {
345                $snippet = $1;
346            }
347            else {
348                s/^\s+//;
349                last;
350            }
351            $field .= $snippet;
352        }
353        push( @words, $field );
354    }
355
356    return @words;
357}
358
359sub apply_command_template {
360    my $self = shift;
361    my %par  = @_;
362    my ( $template, $opts ) = @par{ 'template', 'opts' };
363
364    $template =~ s/<(.*?)>/__DVDRIP_REPEATED_GROUP__/;
365    my ($group_tmpl) = "$1 ";
366
367    my $opts_href = shift @{$opts};
368
369    $template = $self->apply_template(
370        template  => $template,
371        opts_href => $opts_href,
372    );
373
374    my $group = "";
375
376    foreach my $group_opts_href ( @{$opts} ) {
377        $opts_href->{$_} = $group_opts_href->{$_}
378            for keys %{$group_opts_href};
379        $group .= $self->apply_template(
380            template  => $group_tmpl,
381            opts_href => $opts_href,
382        );
383    }
384
385    $template =~ s/__DVDRIP_REPEATED_GROUP__/$group/;
386
387    return $template;
388}
389
390sub apply_template {
391    my $self = shift;
392    my %par  = @_;
393    my ( $template, $opts_href ) = @par{ 'template', 'opts_href' };
394
395    $template =~ s{\%(\(.*?\)|.)}{
396			my $var = $1;
397			if ( $var =~ s/^\((.*)\)$/$1/ ) {
398				$var =~ s/\%(.)/$opts_href->{$1}/g;
399				my $eval = $var;
400				$var = eval $eval;
401				if ( $@ ) {
402					my $err = $@;
403					$err =~ s/at\s+\(.*//;
404					warn "Perl expression ( $eval ) => $err";
405				}
406			} else {
407				$var = $opts_href->{$var};
408			}
409			$var;
410		}eg;
411
412    return $template;
413}
414
415sub search_perl_inc {
416    my $self       = shift;
417    my %par        = @_;
418    my ($rel_path) = @par{'rel_path'};
419
420    my $file;
421
422    foreach my $INC (@INC) {
423        $file = "$INC/$rel_path";
424        last if -e $file;
425        $file = "";
426    }
427
428    return $file;
429}
430
4311;
432