This file is indexed.

/usr/share/perl5/XMLTV/Configure.pm is in libxmltv-perl 0.5.70-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
package XMLTV::Configure;

# use version number for feature detection:
# 0.005065 : can use 'constant' in write_string()
# 0.005065 : comments in config file not restricted to starting in first column
# 0.005066 : make writes to the config-file atomic
our $VERSION = 0.005066;

BEGIN {
    use Exporter   ();
    our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

    @ISA         = qw(Exporter);
    @EXPORT      = qw( );
    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
    @EXPORT_OK   = qw/LoadConfig SaveConfig Configure SelectChannelsStage/;
}
our @EXPORT_OK;

use XMLTV::Ask;
use XMLTV::Config_file;
use XML::LibXML;

=head1 NAME

XMLTV::Configure - Configuration file handling for XMLTV grabbers

=head1 DESCRIPTION

Utility library that helps grabbers read from configuration files
and implement a configuration method that can be run from the
command-line.

=head1 EXPORTED FUNCTIONS

All these functions are exported on demand.

=over 4

=cut

=item LoadConfig

Takes the name of the configuration file to load as a parameter.

Returns a hashref with configuration fieldnames as keys. Note
that the values of the hash are references to an array of values.

Example:
  {
    username => [ 'mattias' ],
    password => [ 'xxx' ],
    channel => [ 'svt1.svt.se', 'kanal5.se' ],
    no_channel => ['svt2.svt.se' ],
  }

Note that unselected options from a selectmany are collected
in an entry named after the key with a prefix of 'no_'. See
the channel and no_channel entry in the example. They are the
result of a selectmany with id=channel.

The configuration file must be in the format described in
the file "ConfigurationFiles.txt". If the file does not
exist or if the format is wrong, LoadConfig returns undef.

=cut

sub LoadConfig
{
    my( $config_file ) = @_;

    my $data = {};

    open IN, "< $config_file" or return undef;

    foreach my $line (<IN>)
    {
	$line =~ tr/\n\r//d;
	next if $line =~ /^\s*$/;
	next if $line =~ /^\s*#/;

	# Only accept lines with key=value or key!value.
	# No white-space is allowed before
	# the equal-sign. White-space after the equal-sign is considered
	# part of the value, except for white-space at the end of the line
	# which is ignored.
	my( $key, $sign, $value ) = ($line=~ /^(\S+)([=!])(.*?)\s*(#.*)?$/ );

	return undef unless defined $key;
	if( $sign eq '=' )
	{
	    push @{$data->{$key}}, $value;
	}
	else
	{
	    push @{$data->{"no_$key"}}, $value;
	}
    }

    close IN;
    return $data;
}

=item SaveConfig

Write a configuration hash in the format returned by LoadConfig to
a file that can be loaded with LoadConfig. Takes two parameters, a reference
to a configuration hash and a filename.

Note that a grabber should normally never have to call SaveConfig. This
is done by the Configure-method.

=cut

sub SaveConfig
{
    my( $conf, $config_file ) = @_;

    # Test if configuration file is writeable
    if (-f $config_file && !(-w $config_file)) { die "Cannot write to $config_file"; }

    # Create temporary configuration file.
    open OUT, "> $config_file.TMP"
	or die "Failed to open $config_file.TMP for writing.";

    foreach my $key (keys %{$conf})
    {
	next if $key eq "channel";
    next if $key eq "lineup";
	foreach my $value (@{$conf->{$key}})
	{
	    print OUT "$key=$value\n";
	}
    }

    if (exists $conf->{lineup}) {
        print OUT "lineup=$conf->{lineup}[0]\n";
    }
    elsif( exists( $conf->{channel} ) )
    {
	foreach my $value (@{$conf->{channel}})
	{
	    print OUT "$key=$value\n";
	}
    }

    close OUT;

    # Store temporary configuration file
    rename "$config_file.TMP", $config_file or die "Failed to write to $config_file";
}

=item Configure

Generates a configuration file for the grabber.

Takes three parameters: stagesub, listsub and the name of the configuration
file.

stagesub shall be a coderef that takes a stage-name or undef
and a configuration hashref as a parameter and returns an
xml-string that describes the configuration necessary for that stage.
The xml-string shall follow the xmltv-configuration.dtd.

listsub shall be a coderef that takes a configuration hash as returned
by LoadConfig as the first parameter and an option hash as returned by
ParseOptions as the second parameter and returns an xml-string
containing a list of all the channels that the grabber can deliver
data for using the supplied configuration. Note that the listsub
shall not use any channel-configuration from the hashref.

=cut

sub Configure
{
    my( $stagesub, $listsub, $conffile, $opt ) = @_;

    # How can we read the language from the environment?
    my $lang = 'en';

    my $nextstage = 'start';

    # Test if configuration file is writeable
    if (-f $conffile && !(-w $conffile)) { die "Cannot write to $conffile"; }

    # Create temporary configuration file.
    open OUT, "> $conffile.TMP" or die "Failed to write to $conffile.TMP";
    close OUT;

    do
    {
	my $stage = &$stagesub( $nextstage, LoadConfig( "$conffile.TMP" ) );
	$nextstage = configure_stage( $stage, $conffile, $lang );
    } while ($nextstage ne "select-channels" );

    # No more nextstage. Let the user select channels. Do not present
    # channel selection if the configuration is using lineups where
    # channels are determined automatically
    my $conf = LoadConfig( "$conffile.TMP" );
    if (! exists $conf->{lineup}) {
        my $channels = &$listsub( $conf, $opt );
        select_channels( $channels, $conffile, $lang );
    }

    # Store temporary configuration file
    rename "$conffile.TMP", $conffile or die "Failed to write to $conffile";
}

sub configure_stage
{
    my( $stage, $conffile, $lang ) = @_;

    my $nextstage = undef;

    open OUT, ">> $conffile.TMP"
	or die "Failed to open $conffile.TMP for writing";

    my $xml = XML::LibXML->new;
    my $doc = $xml->parse_string($stage);

    binmode(STDERR, ":utf8") if ($doc->encoding eq "utf-8");

    my $ns = $doc->find( "//xmltvconfiguration/*" );

    foreach my $p ($ns->get_nodelist)
    {
	my $tag = $p->nodeName;
	if( $tag eq "nextstage" )
	{
	    $nextstage = $p->findvalue( '@stage' );
	    last;
	}

	my $id = $p->findvalue( '@id' );
	my $title = getvalue( $p, 'title', $lang );
	my $description = getvalue( $p, 'description', $lang );
	my $default = $p->findvalue( '@default' );
	my $constant = $p->findvalue( '@constant' );

	my $value;

	my $q = $default ne '' ? "$title: [$default]" :
	                              "$title:";

	say( "$description" ) if $constant eq '';
	if( $tag eq 'string' )
	{
	    $value = $constant if $constant ne '';
	    $value = ask( "$q" ) if $constant eq '';
	    $value = $default if $value eq "";
	    print OUT "$id=$value\n";
	}
	elsif( $tag eq 'secretstring' )
	{
	    $value = ask_password( "$q" );
	    $value = $default if $value eq "";
	    print OUT "$id=$value\n";
	}


	# This must be a selectone or selectmany

	my( @optionvalues, @optiontexts );

	my $ns2 = $p->find( "option" );

	foreach my $p2 ($ns2->get_nodelist)
	{
	    push @optionvalues, $p2->findvalue( '@value' );
	    push @optiontexts, getvalue( $p2, 'text', $lang );
	}

	if( $tag eq "selectone" )
	{
	    my $selected = ask_choice( "$title:", $optiontexts[0],
                                       @optiontexts );
	    for( my $i=0; $i<scalar( @optiontexts ); $i++ )
	    {
		if( $optiontexts[$i] eq $selected )
		{
		    $value=$optionvalues[$i];
		}
	    }
	    print OUT "$id=$value\n";
	}
	elsif( $tag eq "selectmany" )
	{
	    my @answers = ask_many_boolean( 0, @optiontexts );
	    for( my $i=0; $i < scalar( @answers ); $i++ )
	    {
		if( $answers[$i] )
		{
		    print OUT "$id=$optionvalues[$i]\n";
		}
		else
		{
		    print OUT "$id!$optionvalues[$i]\n";
		}
	    }
	}

    }

    close OUT;
    return $nextstage;
}

sub select_channels
{
    my( $channels,  $conffile, $lang ) = @_;

    open OUT, ">> $conffile.TMP"
	or die "Failed to open $conffile.TMP for writing";

    my $xml = XML::LibXML->new;
    my $doc;
    $doc = $xml->parse_string($channels);

    my $ns = $doc->find( "//channel" );

    my @channelname;
    my @channelid;

    foreach my $p ($ns->get_nodelist)
    {
	push @channelid, $p->findvalue( '@id' );
	push @channelname, getvalue($p, "display-name", $lang );
    }

    # We need to internationalize this string.
    say( "Select the channels that you want to receive data for." );

    my @answers = ask_many_boolean( 0, @channelname );
    for( my $i=0; $i < scalar( @answers ); $i++ )
    {
	if( $answers[$i] )
	{
	    print OUT "channel=$channelid[$i]\n";
	}
	else
	{
	    print OUT "channel!$channelid[$i]\n";
	}

    }

    close OUT;
}

sub SelectChannelsStage
{
    my( $channels, $grabber_name ) = @_;

    my $xml = XML::LibXML->new;
    my $doc;
    $doc = $xml->parse_string($channels);
    my $encoding = $doc->encoding;

    my $ns = $doc->find( "//channel" );

    my $result;
    my $writer = new XMLTV::Configure::Writer( OUTPUT => \$result,
					       encoding => $encoding );
    $writer->start( { grabber => $grabber_name } );
    $writer->start_selectmany( {
	id => 'channel',
	title => [ [ 'Channels', 'en' ] ],
	description => [
	 [ "Select the channels that you want to receive data for.",
	   'en' ] ],
     } );

    foreach my $p ($ns->get_nodelist)
    {
	# FIXME: Preserve all languages for the display-name
	$writer->write_option( {
	    value=>$p->findvalue( '@id' ),
	    text=> => [ [ getvalue($p, "display-name", 'en' ),
			  'en'] ],
	} );
    }
    $writer->end_selectmany();
    $writer->end( 'end' );

    return $result;
}

sub getvalue
{
    my( $p, $field, $lang ) = @_;

    # Try the correct language first
    my $value = $p->findvalue( $field . "[\@lang='$lang']");

    # Use English if there is no value for the correct language.
    $value = $p->findvalue( $field . "[\@lang='en']")
	unless length( $value ) > 0;

    # Take the first available value as a last resort.
    $value = $p->findvalue( $field . "[1]")
	unless length( $value ) > 0;

    $value =~ s/^\s+//;
    $value =~ s/\s+$//;
    $value =~ tr/\n\r /   /s;

    return $value;
}

=back

=head1 COPYRIGHT

Copyright (C) 2005 Mattias Holmlund.

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

=cut

### Setup indentation in Emacs
## Local Variables:
## perl-indent-level: 4
## perl-continued-statement-offset: 4
## perl-continued-brace-offset: 0
## perl-brace-offset: -4
## perl-brace-imaginary-offset: 0
## perl-label-offset: -2
## cperl-indent-level: 4
## cperl-brace-offset: 0
## cperl-continued-brace-offset: 0
## cperl-label-offset: -2
## cperl-extra-newline-before-brace: t
## cperl-merge-trailing-else: nil
## cperl-continued-statement-offset: 2
## indent-tabs-mode: t
## End: