1package XMLTV::ValidateGrabber;
2
3use strict;
4
5BEGIN {
6    use Exporter   ();
7    our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
8
9    @ISA         = qw(Exporter);
10    @EXPORT      = qw( );
11    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
12    @EXPORT_OK   = qw/ConfigureGrabber ValidateGrabber/;
13}
14our @EXPORT_OK;
15
16my $CMD_TIMEOUT = 600;
17
18=head1 NAME
19
20XMLTV::ValidateGrabber - Validates an XMLTV grabber
21
22=head1 DESCRIPTION
23
24Utility library that validates that a grabber properly implements the
25capabilities described at
26
27http://wiki.xmltv.org/index.php/XmltvCapabilities
28
29The ValidateGrabber call first asks the grabber which capabilities it
30claims to support and then validates that it actually does support
31these capabilities.
32
33=head1 EXPORTED FUNCTIONS
34
35All these functions are exported on demand.
36
37=over 4
38
39=cut
40
41use XMLTV::ValidateFile qw/ValidateFile/;
42
43use File::Slurp qw/read_file/;
44use File::Spec::Functions qw/devnull/;
45use List::Util qw(min);
46
47my $runfh;
48
49sub w;
50sub run;
51sub run_capture;
52
53=item ConfigureGrabber
54
55    ConfigureGrabber( "./tv_grab_new", "./tv_grab_new.conf" )
56
57=cut
58
59sub ConfigureGrabber {
60    my( $exe, $conf ) = @_;
61
62    if ( run( "$exe --configure --config-file $conf" ) ) {
63	w "Error returned from grabber during configure.";
64	return 1;
65    }
66
67    return 1;
68}
69
70=item ValidateGrabber
71
72Run the validation for a grabber.
73
74    ValidateGrabber( "tv_grab_new", "./tv_grab_new", "./tv_grab_new.conf",
75		     "/tmp/new_", "./blib/share", 0 )
76
77ValidateGrabber takes the following parameters:
78
79=over
80
81=item *
82
83a short name for the grabber. This is only used when printing error messages.
84
85=item *
86
87the command to run the grabber.
88
89=item *
90
91the name of a configuration-file for the grabber.
92
93=item *
94
95a file-prefix that is added to all output-files.
96
97=item *
98
99a path to a directory with metadata for the grabber. This path
100is passed to the grabber via the --share option if the grabber
101supports the capability 'share'. undef if no --share parameter shall
102be used.
103
104=item *
105
106a boolean specifying if the --cache parameter shall be used for grabbers
107that support the 'cache' capability.
108
109=back
110
111ValidateGrabber returns a list of errors that it found with the grabber. Each
112error takes the form of a keyword:
113
114=over
115
116=item noparamcheck
117
118The grabber accepts any parameter without returning an error-code.
119
120=item noversion
121
122The grabber returns an error when run with --version.
123
124=item nodescription
125
126The grabber returns an error when run with --description.
127
128=item nocapabilities
129
130The grabber returns an error when run with --capabilities.
131
132=item nobaseline
133
134The grabber does not list 'baseline' as one of its supported capabilities.
135
136=item nomanualconfig
137
138The grabber does not list 'manualconfig' as one of its supported capabilities.
139
140=item noconfigurationfile
141
142The specified configuration-file does not exist.
143
144=item graberror
145
146The grabber returned with an error-code when asked to grab data.
147
148=item notquiet
149
150The grabber printed something to STDERR even though the --quiet option
151was used.
152
153=item outputdiffers
154
155The grabber produced different output when called with different combinations
156of --output and --quiet.
157
158=item caterror
159
160tv_cat returned an error-code when we asked it to process the output from
161the grabber.
162
163=item sorterror
164
165tv_sort found errors in the data generated by the grabber. Probably overlapping
166programmes.
167
168=item notadditive
169
170grabbing data for tomorrow first and then for the day after tomorrow and
171concatenating them does not yield the same result as grabbing the data
172for tomorrow and the day after tomorrow at once.
173
174=back
175
176Additionally, the list of errors will contain error keywords from
177XMLTV::ValidateFile if the xmltv-file generated by the grabber was not
178valid.
179
180If no errors are found, an empty list is returned.
181
182=cut
183
184sub ValidateGrabber {
185    my( $shortname, $exe, $conf, $op, $sharedir, $usecache ) = @_;
186
187    # if sharedir contains 'blib' we should prepend the relevant development paths!
188    if( defined $sharedir && $sharedir =~ m|/blib/share/$| ) {
189      my( $blib )=( $sharedir =~ m|^(.*/blib)/share/$| );
190
191      use Env qw(@PATH @PERL5LIB);
192      unshift( @PATH, $blib . '/script' );
193      unshift( @PERL5LIB, $blib . '/lib' );
194    }
195
196    my @errors;
197    open( $runfh, ">${op}commands.log" )
198	or die "Failed to write to ${op}commands.log";
199
200    if (not run( "$exe --ahdmegkeja > " . devnull() . " 2>&1" )) {
201      w "$shortname with --ahdmegkeja did not fail. The grabber seems to "
202	  . "accept any command-line parameter without returning an error.";
203      push @errors, "noparamcheck";
204    }
205
206    if (run( "$exe --version > " . devnull() . " 2>&1" )) {
207      w "$shortname with --version failed: $?, $!";
208      push @errors, "noversion";
209    }
210
211    if (run( "$exe --description > " . devnull() . " 2>&1" )) {
212      w "$shortname with --description failed: $?, $!";
213      push @errors, "nodescription";
214    }
215
216    my $cap = run_capture( "$exe --capabilities 2> " . devnull() );
217    if (not defined $cap) {
218      w "$shortname with --capabilities failed: $?, $!";
219      push @errors, "nocapabilities";
220    }
221
222    my @capabilities = split( /\s+/, $cap );
223    my %capability;
224    foreach my $c (@capabilities) {
225	$capability{$c} = 1;
226    }
227
228    if (not defined( $capability{baseline} )) {
229	w "The grabber does not claim to support the 'baseline' capability.";
230	push @errors, "nobaseline";
231    }
232
233    if (not defined( $capability{manualconfig} )) {
234	w "The grabber does not claim to support the 'manualconfig' capability.";
235	push @errors, "nomanualconfig";
236    }
237
238    my $extraop = "";
239    $extraop .= "--cache  ${op}cache "
240	if $capability{cache} and $usecache;
241    $extraop .= "--share $sharedir "
242	if $capability{share} and defined( $sharedir );
243
244    if (not -f $conf) {
245	w "Configuration file $conf does not exist. Aborting.";
246	close( $runfh );
247	push @errors, "noconfigurationfile";
248	goto bailout;
249    }
250
251    # Should we test for --list-channels?
252
253    my $cmd = "$exe --config-file $conf --offset 1 --days 2 $extraop";
254
255    my $output = "${op}1_2";
256
257    if (run "$cmd > $output.xml --quiet 2>${op}1.log") {
258	w "$shortname failed: See ${op}1.log";
259	push @errors, "graberror";
260	goto bailout;
261    }
262    else {
263	if ( -s "${op}1.log" ) {
264	    w "$shortname with --quiet produced output to STDERR when it " .
265		"shouldn't have. See ${op}1.log";
266	    push @errors, "notquiet";
267	}
268	else {
269	    unlink( "${op}1.log" );
270	}
271
272	# Okay, it ran, and we have the result in $output.xml.  Validate.
273	my @xmlerr = ValidateFile( "$output.xml" );
274	if (scalar(@xmlerr) > 0) {
275	    w "Errors found in $output.xml";
276	    close( $runfh );
277	    push @errors, @xmlerr;
278	    goto bailout;
279	}
280	w "$output.xml validates ok";
281
282	# Run through tv_cat, which makes sure the data looks like XMLTV.
283	# What kind of errors does this catch that ValidateFile misses?
284	if (not cat_file( "$output.xml", devnull(), "${op}6.log" )) {
285	    w "$output.xml makes tv_cat choke, see ${op}6.log";
286	    push @errors, "caterror";
287	    goto bailout;
288	}
289
290	# Do tv_sort sanity checks.  One day it would be better to put
291	# this stuff in a Perl library.
292	my $sort_errors = "$output.sort.log";
293	if (not sort_file( "$output.xml", "$output.sorted.xml",
294			   $sort_errors )) {
295	    w "tv_sort failed on $output.xml, probably because of strange " .
296		"start or stop times. See $sort_errors";
297	    push @errors, "sorterror";
298	}
299
300    }
301
302    # Run again to see that --output and --quiet works and to see that
303    # --offset 1 --days 2 equals --offset 1 days 1 plus --offset 2 --days 1.
304    my $output2 = "${op}1_1.xml";
305    my $cmd2 = "$exe --config-file $conf --offset 1 --days 1 $extraop"
306	. " --output $output2  2>${op}2.log";
307
308    if (run $cmd2) {
309	w "$shortname with --output failed: See ${op}2.log";
310	push @errors, "graberror";
311    }
312
313    my $output3 = "${op}2_1.xml";
314    my $cmd3 = "$exe --config-file $conf --offset 2 --days 1 $extraop"
315	. " > $output3 2>${op}3.log";
316
317    if (run $cmd3 ) {
318	w "$shortname with --quiet failed: See ${op}3.log";
319	push @errors, "graberror";
320    }
321    else {
322	unlink( "${op}3.log" );
323    }
324
325    my $output4 = "${op}4.xml";
326    my $cmd4 = "$cmd --quiet --output $output4 2>${op}4.log";
327
328    if (run $cmd4 ) {
329	w "$shortname with --quiet and --output failed: See ${op}4.log";
330	push @errors, "graberror";
331    }
332    else {
333	if ( -s "${op}4.log" ) {
334	    w "$shortname with --quiet and --output produced output " .
335		"to STDERR when it shouldn't have. See ${op}4.log";
336	    push @errors, "notquiet";
337	}
338	else {
339	    unlink( "${op}4.log" );
340	}
341    }
342
343    if (not cat_files( $output2, $output3, "${op}1_2-2.xml", "${op}5.log" )) {
344	w "tv_cat failed to concatenate the data. See ${op}5.log";
345	push @errors, "caterror";
346    }
347
348    if (not sort_file( "${op}1_2-2.xml", "${op}1_2-2.sorted.xml",
349		       "${op}7.log" )) {
350	w "tv_sort failed on the concatenated data. Probably due " .
351	    "to overlapping data between days. See ${op}7.log";
352	push @errors, "notadditive";
353    }
354
355    if( !compare_files( "$output.sorted.xml", "${op}1_2-2.sorted.xml",
356			"${op}1_2.diff" ) ) {
357	w "The data is not additive. See ${op}1_2.diff";
358	push @errors, "notadditive";
359    }
360
361  bailout:
362    close( $runfh );
363    $runfh = undef;
364
365    # Remove duplicate entries.
366    my $lasterror = "nosucherror";
367    my @ferrors;
368    foreach my $err (@errors) {
369	push( @ferrors, $err ) if $err ne $lasterror;
370	$lasterror = $err;
371    }
372
373    if (scalar( @ferrors )) {
374	w "$shortname did not validate ok. See ${op}commands.log for a "
375	    . "list of the commands that were used";
376    }
377    else {
378	w "$shortname validated ok.";
379    }
380
381    return @ferrors;
382}
383
384sub w {
385    print "$_[0]\n";
386}
387
388# Run an external command. Exit if the command is interrupted with ctrl-c.
389sub run {
390    my( $cmd ) = @_;
391
392    print $runfh "$cmd\n"
393	if defined $runfh;
394
395    my $killed = 0;
396
397    # Set a timer and run the real command.
398    eval {
399	local $SIG{ALRM} =
400            sub {
401		# ignore SIGHUP here so the kill only affects children.
402		local $SIG{HUP} = 'IGNORE';
403		kill 1,(-$$);
404		$killed = 1;
405	    };
406	alarm $CMD_TIMEOUT;
407	system ( $cmd );
408	alarm 0;
409    };
410    $SIG{HUP} = 'DEFAULT';
411
412    if ($killed) {
413	w "Timeout";
414	return 1;
415    }
416
417    if ($? == -1) {
418	w "Failed to execute $cmd: $!";
419	return 1;
420    }
421    elsif ($? & 127) {
422	w "Terminated by signal " . ($? & 127);
423	exit 1;
424    }
425
426    return $? >> 8;
427}
428
429# Run an external command and return the output. Exit if the command is
430# interrupted with ctrl-c.
431sub run_capture {
432    my( $cmd ) = @_;
433
434#    print "Running $cmd\n";
435
436    my $killed = 0;
437    my $result;
438
439    # Set a timer and run the real command.
440    eval {
441	local $SIG{ALRM} =
442            sub {
443		# ignore SIGHUP here so the kill only affects children.
444		local $SIG{HUP} = 'IGNORE';
445		kill 1,(-$$);
446		$killed = 1;
447	    };
448	alarm $CMD_TIMEOUT;
449	$result = qx/$cmd/;
450	alarm 0;
451    };
452    $SIG{HUP} = 'DEFAULT';
453
454    if ($killed) {
455	w "Timeout";
456	return undef;
457    }
458
459    if ($? == -1) {
460	w "Failed to execute $cmd: $!";
461	return undef;
462    }
463    elsif ($? & 127) {
464	w "Terminated by signal " . ($? & 127);
465	exit 1;
466    }
467
468    if ($? >> 8) {
469	return undef;
470    }
471    else {
472	return $result;
473    }
474}
475
476# Compare two files. Return true if they have the same contents.
477sub compare_files {
478    my( $file1, $file2, $output ) = @_;
479
480    $output = devnull() unless defined $output;
481    run("diff $file1 $file2 > $output");
482    return $? ? 0 : 1;
483}
484
485# Run an xmltv-file through tv_cat. Return true on success.
486sub cat_file {
487    my( $file1, $outfile, $logfile ) = @_;
488
489    my $ret = run( "tv_cat $file1 > $outfile 2>$logfile" );
490
491    return $ret ? 0 : 1;
492}
493
494# Concatenate two xmltv-files. Return true on success.
495sub cat_files {
496    my( $file1, $file2, $outfile, $logfile ) = @_;
497
498    my $ret = run( "tv_cat $file1 $file2 > $outfile 2>$logfile" );
499
500    return $ret ? 0 : 1;
501}
502
503# Sort an xmltv-file. Return true on success
504sub sort_file {
505    my( $file1, $outfile, $logfile ) = @_;
506
507    my $ret = run( "tv_sort --duplicate-error $file1 > $outfile 2>$logfile" );
508
509    return 0 if -s $logfile > 0;
510    return $ret ? 0 : 1;
511}
512
5131;
514
515
516=back
517
518=head1 COPYRIGHT
519
520Copyright (C) 2006 Mattias Holmlund.
521
522This program is free software; you can redistribute it and/or
523modify it under the terms of the GNU General Public License
524as published by the Free Software Foundation; either version 2
525of the License, or (at your option) any later version.
526
527This program is distributed in the hope that it will be useful,
528but WITHOUT ANY WARRANTY; without even the implied warranty of
529MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
530GNU General Public License for more details.
531
532You should have received a copy of the GNU General Public License
533along with this program; if not, write to the Free Software
534Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
535
536=cut
537
538### Setup indentation in Emacs
539## Local Variables:
540## perl-indent-level: 4
541## perl-continued-statement-offset: 4
542## perl-continued-brace-offset: 0
543## perl-brace-offset: -4
544## perl-brace-imaginary-offset: 0
545## perl-label-offset: -2
546## cperl-indent-level: 4
547## cperl-brace-offset: 0
548## cperl-continued-brace-offset: 0
549## cperl-label-offset: -2
550## cperl-extra-newline-before-brace: t
551## cperl-merge-trailing-else: nil
552## cperl-continued-statement-offset: 2
553## indent-tabs-mode: t
554## End:
555