File Coverage

blib/lib/Linux/DVB/DVBT/Config.pm

Criterion	Covered	Total	%
statement	379	701	54.0
branch	145	364	39.8
condition	24	93	25.8
subroutine	27	43	62.7
pod	28	28	100.0
total	603	1229	49.0

package Linux::DVB::DVBT::Config ;

=head1 NAME

Linux::DVB::DVBT::Config - DVBT configuration functions

=head1 SYNOPSIS

	use Linux::DVB::DVBT::Config ;


=head1 DESCRIPTION

Module provides a set of configuration routines used by the DVBT module. It is unlikely that you will need to access these functions directly, but
you can if you wish.

=cut


use strict ;

use Data::Dumper ;

our $VERSION = '2.08' ;
our $DEBUG = 0 ;

our $DEFAULT_CONFIG_PATH = '/etc/dvb:~/.tv' ;

use File::Path ;
use File::Spec ;

my %FILES = (
	'ts'		=> { 'file' => "dvb-ts", 		'required' => 1 },
	'pr'		=> { 'file' => "dvb-pr",		'required' => 1 },
	'aliases'	=> { 'file' => "dvb-aliases",	'required' => 0 },
) ;

my %NUMERALS = (
	'one'	=> 1,
	'two'	=> 2,
	'three'	=> 3,
	'four'	=> 4,
	'five'	=> 5,
	'six'	=> 6,
	'seven'	=> 7,
	'eight'	=> 8,
	'nine'	=> 9,
) ;

our @SCAN_INFO_FIELDS = qw/pr ts lcn freqs/ ;

#============================================================================================

=head2 Functions

=over 4

=cut



#----------------------------------------------------------------------

=item B

Given a frequency, find the matching TSID.

$tuning_href is the HASH returned by L.

=cut

sub find_tsid
{
	my ($frequency, $tuning_href) = @_ ;
	my $tsid ;

#	'ts' =>
#	      4107 =>
#	        {
#	          tsid => 4107,
#			  frequency => 57800000,
#	          ...
#	        },

	foreach my $this_tsid (keys %{$tuning_href->{'ts'}})
	{
		if ($frequency == $tuning_href->{'ts'}{$this_tsid}{'frequency'})
		{
			$tsid = $this_tsid ;
			last ;
		}
	}
	return $tsid ;
}

#----------------------------------------------------------------------

=item B

Given a tsid, return the frontend params (or undef). The frontend params HASH
contain the information used to tune the frontend i.e. this is the transponder
(TSID) information. It corresponds to the matching 'ts' entry in the tuning info
HASH.

$tuning_href is the HASH returned by L.

=cut

sub tsid_params
{
	my ($tsid, $tuning_href) = @_ ;

	my $params_href ;

#	'ts' =>
#	      4107 =>
#	        {
#	          tsid => 4107,
#			  frequency => 57800000,
#	          ...
#	        },

	if ($tsid && exists($tuning_href->{'ts'}{$tsid}))
	{
		$params_href = $tuning_href->{'ts'}{$tsid} ;
	}

	return $params_href ;
}

#----------------------------------------------------------------------

=item B

Given a tsid and pid, find the matching channel information and returns the
program HASH ref if found. This corresponds to the matching 'pr' entry in the tuning
info HASH.

$tuning_href is the HASH returned by L.

=cut

sub chan_from_pid
{
	my ($tsid, $pid, $tuning_href) = @_ ;
	my $pr_href ;

	# skip PAT
	return $pr_href unless $pid ;

#	'pr' =>
#	      BBC ONE =>
#	        {
#	          pnr => 4171,
#	          tsid => 4107,
#	          tuned_freq => 57800000,
#	          ...
#	        },

	foreach my $chan (keys %{$tuning_href->{'pr'}})
	{
#		if ($tsid == $tuning_href->{'pr'}{$chan}{'tsid'})
		if ($tsid eq $tuning_href->{'pr'}{$chan}{'tsid'})
		{
			foreach my $stream (qw/video audio teletext subtitle/)
			{
				if ($pid == $tuning_href->{'pr'}{$chan}{$stream})
				{
					$pr_href = $tuning_href->{'pr'}{$chan} ;
					last ;
				}
			}
			last if $pr_href ;

			# check other audio
			my @audio = audio_list( $tuning_href->{'pr'}{$chan} ) ;
			foreach (@audio)
			{
				if ($pid == $_)
				{
					$pr_href = $tuning_href->{'pr'}{$chan} ;
					last ;
				}
			}
		}

		last if $pr_href ;
	}

	return $pr_href ;
}

#----------------------------------------------------------------------

=item B

Given a pid, find the matching channel & TSID information

Returns an array of HASH entries, each HASH containing the stream type (video, audio, subtitle, or
teletext), along with a copy of the associated program information (i.e. the matching 'pr' entry from the
tuning info HASH):

	@pid_info = [
		{
			  'pidtype' => video, audio, subtitle, teletext
		     pnr => 4171,
		     tsid => 4107,
		     tuned_freq => 57800000,
		          ...
		},
		...
	]


$tuning_href is the HASH returned by L.

=cut

sub pid_info
{
	my ($pid, $tuning_href) = @_ ;

print "pid_info(pid=\"$pid\")\n" if $DEBUG ;

	my @pid_info ;

	# skip PAT
	return @pid_info unless $pid ;

	foreach my $chan (keys %{$tuning_href->{'pr'}})
	{
		my $tsid = $tuning_href->{'pr'}{$chan}{'tsid'} ;

		# program
		my @chan_pids ;
		foreach my $stream (qw/video audio teletext subtitle/)
		{
			push @chan_pids, [$stream, $tuning_href->{'pr'}{$chan}{$stream}] ;
		}

		# extra audio
		my @audio = audio_list( $tuning_href->{'pr'}{$chan} ) ;
		foreach (@audio)
		{
			push @chan_pids, ['audio', $_] ;
		}

		# extra subtitle by rainbowcrypt
		my @sub = sub_list( $tuning_href->{'pr'}{$chan} ) ;
		foreach (@sub)
		{
			push @chan_pids, ['subtitle', $_] ;
		}

		# SI
		foreach my $si (qw/pmt/)
		{
			push @chan_pids, [uc $si, $tuning_href->{'pr'}{$chan}{$si}] ;
		}


		# check pids
		foreach my $aref (@chan_pids)
		{
			if ($pid == $aref->[1])
			{
print " + pidtype=$aref->[0]\n" if $DEBUG ;
				push @pid_info, {
					%{$tuning_href->{'pr'}{$chan}},
					'pidtype'		=> $aref->[0],

					# keep ref to program HASH (used by downstream functions)
					'demux_params'	=> $tuning_href->{'pr'}{$chan},
				} ;
			}
		}
	}

	return @pid_info ;
}

#----------------------------------------------------------------------

=item B

Given a channel name, do a "fuzzy" search and return an array containing params:

	($frontend_params_href, $demux_params_href)

$demux_params_href HASH ref are of the form:

	        {
	          pnr => 4171,
	          tsid => 4107,
	          tuned_freq => 57800000,
	          ...
	        },

(i.e. $tuning_href->{'pr'}{$channel_name})

$frontend_params_href HASH ref are of the form:

	        {
	          tsid => 4107,
			  frequency => 57800000,
	          ...
	        },

(i.e. $tuning_href->{'ts'}{$tsid} where $tsid is TSID for the channel)

$tuning_href is the HASH returned by L.

=cut

sub find_channel
{
	my ($channel_name, $tuning_href) = @_ ;

	my ($frontend_params_href, $demux_params_href) ;

	## Look for channel info
	print STDERR "find $channel_name ...\n" if $DEBUG ;

	$channel_name = _channel_alias($channel_name, $tuning_href->{'aliases'}) ;
	my $found_channel_name = _channel_search($channel_name, $tuning_href->{'pr'}) ;
	if ($found_channel_name)
	{
		$demux_params_href = $tuning_href->{'pr'}{$found_channel_name} ;
	}

	## If we've got the channel, look up it's frontend settings
	if ($demux_params_href)
	{
		my $tsid = $demux_params_href->{'tsid'} ;
		$frontend_params_href = {
			%{$tuning_href->{'ts'}{$tsid}},
			'tsid'	=> $tsid,
		} ;
	}

	return ($frontend_params_href, $demux_params_href) ;
}


#----------------------------------------------------------------------
# Do "fuzzy" search for channel name
#
sub _channel_search
{
	my ($channel_name, $search_href) = @_ ;

	my $found_channel_name ;

	# start by just seeing if it's the correct name...
	if (exists($search_href->{$channel_name}))
	{
		return $channel_name ;
	}
	else
	{
		## Otherwise, try finding variations on the channel name
		my %search ;

		$channel_name = lc $channel_name ;

		# lower-case, no spaces
		my $srch = $channel_name ;
		$srch =~ s/\s+//g ;
		$search{$srch}=1 ;

		# lower-case, replaced words with numbers, no spaces
		$srch = $channel_name ;
		foreach my $num (keys %NUMERALS)
		{
			$srch =~ s/\b($num)\b/$NUMERALS{$num}/ge ;
		}
		$srch =~ s/\s+//g ;
		$search{$srch}=1 ;

		# lower-case, replaced numbers with words, no spaces
		$srch = $channel_name ;
		foreach my $num (keys %NUMERALS)
		{
print STDERR " -- $srch - replace $NUMERALS{$num} with $num..\n" if $DEBUG>3 ;
			$srch =~ s/($NUMERALS{$num})\b/$num/ge ;
print STDERR " -- -- $srch\n" if $DEBUG>3 ;
		}
		$srch =~ s/\s+//g ;
		$search{$srch}=1 ;

		print STDERR " + Searching tuning info [", keys %search, "]...\n" if $DEBUG>2 ;

		foreach my $chan (keys %$search_href)
		{
			my $srch_chan = lc $chan ;
			$srch_chan =~ s/\s+//g ;

			foreach my $search (keys %search)
			{
				print STDERR " + + checking $search against $srch_chan \n" if $DEBUG>2 ;
				if ($srch_chan eq $search)
				{
					$found_channel_name = $chan ;
					print STDERR " + found $channel_name\n" if $DEBUG ;
					last ;
				}
			}

			last if $found_channel_name ;
		}
	}

	return $found_channel_name ;
}


#----------------------------------------------------------------------
# Lookup channel name alias (if it exists)
#
sub _channel_alias
{
	my ($channel_name, $alias_href) = @_ ;

	if ($alias_href && scalar(keys %$alias_href))
	{
print STDERR "Searching channel aliases for \"$channel_name\" ... \n" if $DEBUG>3 ;
		my $alias_key = _channel_search($channel_name, $alias_href) ;
		if ($alias_key)
		{
			my $alias = $alias_href->{$alias_key} ;
print STDERR "... using alias \"$alias\" for \"$channel_name\"\n" if $DEBUG>3 ;
			$channel_name = $alias ;
		}
	}

	return $channel_name ;
}

#----------------------------------------------------------------------

=item B

Process the demux parameters and a language specifier to return the list of audio
streams required.

demux_params are of the form:

	        {
	          pnr => 4171,
	          tsid => 4107,
	          tuned_freq => 57800000,
	          ...
	        },

(i.e. $tuning_href->{'pr'}{$channel_name})


Language specifier string is in the format:

=over 4

=item a)

Empty string : just return the default audio stream pid

=item b)

Comma/space seperated list of one or more language names : returns the audio stream pids for all that match (does not necessarily include default stream)

=back

If the list in (b) contains a '+' character (normally at the start) then the default audio stream is automatically included in teh list, and the
extra streams are added to it.

For example, if a channel has the following audio details: eng:100 eng:101 fra:102 deu:103
Then the following specifications result in the lists as shown:

=over 4

=item *

"" => (100)

=item *

"eng deu" => (100, 103)

=item *

"+eng fra" => (100, 101, 102)

=back

Note that the language names are not case sensitive


=cut

sub audio_pids
{
	my ($demux_params_href, $language_spec, $pids_aref) = @_ ;
	my $error = 0 ;

print "audio_pids(lang=\"$language_spec\")\n" if $DEBUG ;

	my $audio_pid = $demux_params_href->{'audio'} ;

	## simplest case is no language spec
	$language_spec ||= "" ;
	if (!$language_spec)
	{
print " + simplest case - add default audio $audio_pid\n" if $DEBUG ;

		push @$pids_aref, $audio_pid ;
		return 0 ;
	}

	# split details
	my @audio_details ;
	my $details = $demux_params_href->{'audio_details'} ;
print "audio_details=\"$details\")\n" if $DEBUG ;
	while ($details =~ m/(\S+):(\d+)/g)
	{
		my ($lang, $pid) = ($1, $2) ;
		push @audio_details, {'lang'=>lc $lang, 'pid'=>$pid} ;

print " + lang=$audio_details[-1]{lang}  pid=$audio_details[-1]{pid}\n" if $DEBUG >= 10 ;
	}

	# drop default audio
	shift @audio_details ;

	# process language spec
	if ($language_spec =~ s/\+//g)
	{
		# ensure default is in the list
		push @$pids_aref, $audio_pid ;

print " - lang spec contains '+', added default audio\n" if $DEBUG >= 10 ;
	}

print "process lang spec\n" if $DEBUG >= 10 ;

	# work through the language spec
	my $pid ;
	my $lang ;
	my @lang = split /[\s,]+/, $language_spec ;
	while (@lang)
	{
		$lang = shift @lang ;

print " + lang=$lang\n" if $DEBUG >= 10 ;

		$pid = undef ;
		while (!$pid && @audio_details)
		{
			my $audio_href = shift @audio_details ;
print " + + checking this audio detail: lang=$audio_href->{lang}  pid=$audio_href->{pid}\n" if $DEBUG >= 10 ;
			if ($audio_href->{'lang'} =~ /$lang/i)
			{
				$pid = $audio_href->{'pid'} ;
print " + + Found pid = $pid\n" if $DEBUG >= 10 ;

				push @$pids_aref, $pid ;
print " + Added pid = $pid\n" if $DEBUG >= 10 ;
			}
		}
		last unless @audio_details ;
	}

	# clean up
	if (@lang || !$pid)
	{
		unshift @lang, $lang if $lang ;
		$error = "Error: could not find the languages: " . join(', ', @lang) . " associated with program \"$demux_params_href->{pnr}\"" ;
	}

	return $error ;
}
#----------------------------------------------------------------------

=item B #copy/paste from audio_pid by rainbowcrypt

Process the demux parameters and a language specifier to return the list of audio
streams required.

demux_params are of the form:

	        {
	          pnr => 4171,
	          tsid => 4107,
	          tuned_freq => 57800000,
	          ...
	        },

(i.e. $tuning_href->{'pr'}{$channel_name})


Language specifier string is in the format:

=over 4

=item a)

Empty string : just return the default audio stream pid

=item b)

Comma/space seperated list of one or more language names : returns the audio stream pids for all that match (does not necessarily include default stream)

=back

If the list in (b) contains a '+' character (normally at the start) then the default audio stream is automatically included in teh list, and the
extra streams are added to it.

For example, if a channel has the following audio details: eng:100 eng:101 fra:102 deu:103
Then the following specifications result in the lists as shown:

=over 4

=item *

"" => (100)

=item *

"eng deu" => (100, 103)

=item *

"+eng fra" => (100, 101, 102)

=back

Note that the language names are not case sensitive


=cut

sub subtitle_pids
{ #copy/paste from audio_pid by rainbowcrypt
	my ($demux_params_href, $language_spec, $pids_aref) = @_ ;
	my $error = 0 ;

print "subtitle_pids(lang=\"$language_spec\")\n" if $DEBUG ;

	my $subtitle_pid = $demux_params_href->{'subtitle'} ;

	## simplest case is no language spec
	$language_spec ||= "" ;
	if (!$language_spec)
	{
print " + simplest case - add default subtitle $subtitle_pid\n" if $DEBUG ;

		push @$pids_aref, $subtitle_pid ;
		return 0 ;
	}

	# split details
	my @subtitle_details ;
	my $details = $demux_params_href->{'subtitle_details'} || "" ;
print "subtitle_details=\"$details\")\n" if $DEBUG ;
	while ($details =~ m/(\S+):(\d+)/g)
	{
		my ($lang, $pid) = ($1, $2) ;
		push @subtitle_details, {'lang'=>lc $lang, 'pid'=>$pid} ;

print " + lang=$subtitle_details[-1]{lang}  pid=$subtitle_details[-1]{pid}\n" if $DEBUG >= 10 ;
	}

	# drop default audio
	shift @subtitle_details ;

	# process language spec
	if ($language_spec =~ s/\+//g)
	{
		# ensure default is in the list
		push @$pids_aref, $subtitle_pid ;

print " - lang spec contains '+', added default subtitle\n" if $DEBUG >= 10 ;
	}

print "process lang spec\n" if $DEBUG >= 10 ;

	# work through the language spec
	my $pid ;
	my $lang ;
	my @lang = split /[\s,]+/, $language_spec ;
	while (@lang)
	{
		$lang = shift @lang ;

print " + lang=$lang\n" if $DEBUG >= 10 ;

		$pid = undef ;
		while (!$pid && @subtitle_details)
		{
			my $subtitle_href = shift @subtitle_details ;
print " + + checking this subtitle detail: lang=$subtitle_href->{lang}  pid=$subtitle_href->{pid}\n" if $DEBUG >= 10 ;
			if ($subtitle_href->{'lang'} =~ /$lang/i)
			{
				$pid = $subtitle_href->{'pid'} ;
print " + + Found pid = $pid\n" if $DEBUG >= 10 ;

				push @$pids_aref, $pid ;
print " + Added pid = $pid\n" if $DEBUG >= 10 ;
			}
		}
		last unless @subtitle_details ;
	}

	# clean up
	if (@lang || !$pid)
	{
		unshift @lang, $lang if $lang ;
		$error = "Error: could not find the languages: " . join(', ', @lang) . " associated with program \"$demux_params_href->{pnr}\"" ;
	}

	return $error ;
}

#----------------------------------------------------------------------

=item B #modified by rainbowcrypt

Process the demux parameters and an output specifier to return the list of all
stream pids required.

Output specifier string is in the format such that it just needs to contain the following characters:

   a = audio
   v = video
   s = subtitle

Returns an array of HASHes of the form:

	 {'pid' => $pid, 'pidtype' => $type, 'pmt' => $pmt}


=cut

sub out_pids
{
	my ($demux_params_href, $out_spec, $language_spec, $subtitle_language_spec, $pids_aref) = @_ ;
	my $error = 0 ;

	## default
	$out_spec ||= "av" ;

#	my $pmt = $demux_params_href->{'pmt'} ;

	## Audio required?
	if ($out_spec =~ /a/i)
	{
		my @audio_pids ;
		$error = audio_pids($demux_params_href, $language_spec, \@audio_pids) ;
		return $error if $error ;

		foreach my $pid (@audio_pids)
		{
			push @$pids_aref, {
				'pid' => $pid,
				'pidtype' => 'audio',

				# keep ref to program HASH (used by downstream functions)
				'demux_params'	=> $demux_params_href,
			} if $pid ;
		}
	}

	## Video required?
	if ($out_spec =~ /v/i)
	{
		my $pid = $demux_params_href->{'video'} ;
		push @$pids_aref, {
			'pid' => $pid,
			'pidtype' => 'video',

			# keep ref to program HASH (used by downstream functions)
			'demux_params'	=> $demux_params_href,
		} if $pid ;
	}

	## Subtitle required?
	if ($out_spec =~ /s/i) #modified by rainbowcrypt
	{
		my @subtitle_pids ;
		$error = subtitle_pids($demux_params_href, $subtitle_language_spec, \@subtitle_pids) ;
		return $error if $error ;

		foreach my $pid (@subtitle_pids)
		{
			push @$pids_aref, {
				'pid' => $pid,
				'pidtype' => 'subtitle',

				# keep ref to program HASH (used by downstream functions)
				'demux_params'	=> $demux_params_href,
			} if $pid ;
		}
	}

	return $error ;
}

#----------------------------------------------------------------------

=item B

Process the demux parameters and return a list of additional audio
streams (or an empty list if none available).

For example:

	        {
	          audio => 601,
	          audio_details => eng:601 eng:602,
				...
	        },

would return the list: ( 602 )


=cut

sub audio_list
{
	my ($demux_params_href) = @_ ;
	my @pids ;

	my $audio_pid = $demux_params_href->{'audio'} ;
	my $details = $demux_params_href->{'audio_details'} ;
	while ($details =~ m/(\S+):(\d+)/g)
	{
		my ($lang, $pid) = ($1, $2) ;
		push @pids, $pid if ($pid != $audio_pid) ;
	}

	return @pids ;
}

#----------------------------------------------------------------------

=item B by rainbowcrypt

Process the demux parameters and return a list of additional subtitle
streams (or an empty list if none available).

For example:

	        {
	          subtitle => 601,
	          subtitle_details => DVD_malentendant:601 DVB-francais:602,
				...
	        },

would return the list: ( 602 )


=cut

sub sub_list
{
	my ($demux_params_href) = @_ ;
	my @pids ;

	my $sub_pid = $demux_params_href->{'subtitle'} ;
	my $details = $demux_params_href->{'subtitle_details'} || "" ;
	while ($details =~ m/(\S+):(\d+)/g)
	{
		my ($lang, $pid) = ($1, $2) ;
		push @pids, $pid if ($pid != $sub_pid) ;
	}

	return @pids ;
}


#----------------------------------------------------------------------

=item B

Read tuning information from config files. Look in search path and return first
set of readable file information in a tuning HASH ref.

Returns a HASH ref of tuning information - i.e. it contains the complete information on all
transponders (under the 'ts' field), and all programs (under the 'pr' field). [see L method for format].


=cut

sub read
{
	my ($search_path) = @_ ;

	$search_path = $DEFAULT_CONFIG_PATH unless defined($search_path) ;

	my $href ;
	my $dir = read_dir($search_path) ;
	if ($dir)
	{
		$href = {} ;
		foreach my $region (keys %FILES)
		{
		no strict "refs" ;
			my $fn = "read_dvb_$region" ;

			print STDERR " + Running $fn() for $region ...\n" if $DEBUG ;

			$href->{$region} = &$fn("$dir/$FILES{$region}{'file'}") ;
		}

		## Special case - get tuning info if present
		$href->{'freqfile'} = read_dvb_ts_freqs("$dir/$FILES{ts}{'file'}") ;

		print STDERR "Read config from $dir\n" if $DEBUG ;
		print STDERR Data::Dumper->Dump(["Config=", $href]) if $DEBUG >= 5 ;

	}
	return $href ;
}

#----------------------------------------------------------------------

=item B

Write tuning information into the first writeable area in the search path.

=cut

sub write
{
	my ($search_path, $href) = @_ ;

	$search_path = $DEFAULT_CONFIG_PATH unless defined($search_path) ;
	my $dir = write_dir($search_path) ;
	if ($dir && $href)
	{
		foreach my $region (keys %FILES)
		{
		no strict "refs" ;
			my $fn = "write_dvb_$region" ;
			&$fn("$dir/$FILES{$region}{'file'}", $href->{$region}, $href->{'freqfile'}) ;
		}

		print STDERR "Written config to $dir\n" if $DEBUG ;
	}
}


#----------------------------------------------------------------------

=item B

Returns the readable filename for the specified file type, which can be one of: 'pr'=program, 'ts'=transponder.

Optionally specify the search path (otherwise the default search path is used)

Returns undef if invalid file type is specified, or unable to find a readable area.

=cut

sub read_filename
{
	my ($filetype, $search_path) = @_ ;

	my $filename ;
	return $filename if (!exists($FILES{$filetype}));

	$search_path = $DEFAULT_CONFIG_PATH unless defined($search_path) ;
	my $dir = read_dir($search_path) ;

	if ($dir)
	{
		$filename = "$dir/$FILES{$filetype}{'file'}" ;
	}
	return $filename ;
}

#----------------------------------------------------------------------

=item B

Returns the writeable filename for the specified file type, which can be one of: 'pr'=program, 'ts'=transponder.

Optionally specify the search path (otherwise the default search path is used)

Returns undef if invalid file type is specified, or unable to find a writeable area.

=cut

sub write_filename
{
	my ($filetype, $search_path) = @_ ;

	my $filename ;
	return $filename if (!exists($FILES{$filetype}));

	$search_path = $DEFAULT_CONFIG_PATH unless defined($search_path) ;
	my $dir = write_dir($search_path) ;

	if ($dir)
	{
		$filename = "$dir/$FILES{$filetype}{'file'}" ;
	}
	return $filename ;
}


#----------------------------------------------------------------------

=item B

Sorts TSIDs. As I now allow duplicate TSIDs in scans, and the duplicates
are suffixed with a letter to make it obvious, numeric sorting is not possible.

This function can be used to correctly sort the TSIDs into order. Returns the usual
-1, 0, 1 depending on if a is <, ==, or > b

=cut

sub tsid_sort
{
	my ($tsid_a, $tsid_b) = @_ ;

	my $a_int = int($tsid_a) ;
	my $b_int = int($tsid_b) ;

	return
		$a_int <=> $b_int
			||
		$tsid_a cmp $tsid_b
	 ;
}

#----------------------------------------------------------------------

=item B

Format the tsid number/name into a string. As I now allow duplicate TSIDs in
scans, and the duplicates are suffixed with a letter to make it obvious which
are duplicates. This routine formats the numeric part and always adds a suffix
character (or space if none present).

=cut

sub tsid_str
{
	my ($tsid) = @_ ;

	my ($tsid_int, $tsid_suffix) = ($tsid, " ") ;
	if ($tsid =~ /(\d+)([a-z])/i)
	{
		($tsid_int, $tsid_suffix) = ($1, $2) ;
	}

	return sprintf "%5d$tsid_suffix", $tsid_int ;
}

#----------------------------------------------------------------------

=item B

Remove the specified TSID from the tuning information. Also removes any channels
that are under that TSID.

=cut

sub tsid_delete
{
	my ($tsid, $tuning_href) = @_ ;

	my $ok = 0;
	if (exists($tuning_href->{'ts'}{$tsid}))
	{
		$ok = 1 ;
		my $info_href = _scan_info($tuning_href) ;

		delete $tuning_href->{'ts'}{$tsid} ;

		foreach my $pnr (keys %{$info_href->{'tsid'}{$tsid}{'pr'}} )
		{
			my $chan = $info_href->{'tsid'}{$tsid}{'pr'}{$pnr} ;
			delete $tuning_href->{'pr'}{$chan} ;
		}

	}

	return $ok ;
}



#----------------------------------------------------------------------

=item B

Merge tuning information - overwrites previous with new - into $old_href and return
the HASH ref.

=cut

sub merge
{
	my ($new_href, $old_href, $scan_info_href) = @_ ;

print STDERR Data::Dumper->Dump(["merge - Scan info [$scan_info_href]=", $scan_info_href]) if $DEBUG>=5 ;

	$scan_info_href ||= {} ;

#	region: 'ts' =>
#		section: '4107' =>
#			field: name = Oxford/Bexley
#
	if ($old_href && $new_href)
	{
		foreach my $region (keys %FILES)
		{
			$old_href->{$region} ||= {} ;
			if (exists($new_href->{$region}))
			{
				foreach my $section (keys %{$new_href->{$region}})
				{
					foreach my $field (keys %{$new_href->{$region}{$section}})
					{
						$old_href->{$region}{$section}{$field} = $new_href->{$region}{$section}{$field} ;
					}
				}
			}
		}
	}

	$old_href = $new_href if (!$old_href) ;

print STDERR Data::Dumper->Dump(["merge END - Scan info [$scan_info_href]=", $scan_info_href]) if $DEBUG>=5 ;

	return $old_href ;
}

#----------------------------------------------------------------------

=item B

Merge tuning information - checks to ensure new program info has the
best strength, and that new program has all of it's settings

	'pr' => {
	      BBC ONE =>
	        {
	          pnr => 4171,
	          tsid => 4107,
	          lcn => 1,
	          ...
	        },
	     $chan => ...
	},
	'lcn' => {
	      4107 => {
	      	4171 => {
		          service_type => 2,
				  visible => 1,
		          lcn => 46,
		          ...
		        },
	        },

	     $tsid => {
	     	$pnr => ...
	     }
	},
	'ts' => {
	      4107 =>
	        {
	          tsid => 4107,
			  frequency => 57800000,
	          strength => 46829,
	          ...
	        },
	     $tsid => ..
	},
	'freqs' => {
	      57800000 =>
	        {
	          strength => 46829,
	          snr => bbb,
	          ber => ccc,
	          ...
	        },
	      $freq => ...
	},



=cut


sub merge_scan_freqs
{
	my ($new_href, $old_href, $options_href, $verbose, $scan_info_href) = @_ ;

print STDERR Data::Dumper->Dump(["merge_scan_freqs - Scan info [$scan_info_href]=", $scan_info_href]) if $DEBUG>=5 ;

	$scan_info_href ||= {} ;
	$scan_info_href->{'chans'} ||= {} ;
	$scan_info_href->{'tsids'} ||= {} ;

print STDERR "merge_scan_freqs()\n" if $DEBUG ;

	if ($old_href && $new_href)
	{
print STDERR Data::Dumper->Dump(["New:", $new_href, "Old:", $old_href]) if $DEBUG>=2 ;

		## gather information on new & existing
		my %old_new_info ;
		$old_new_info{'new'} = _scan_info($new_href) ;
		$old_new_info{'old'} = _scan_info($old_href) ;

		## Copy special fields first
		my %fields = map {$_ => 1} @SCAN_INFO_FIELDS ;

		# ts
		delete $fields{'ts'} ;
		_merge_tsid($new_href, $old_href, $options_href, $verbose, $scan_info_href, \%old_new_info) ;

		# pr
		delete $fields{'pr'} ;
		_merge_chan($new_href, $old_href, $options_href, $verbose, $scan_info_href, \%old_new_info) ;

		# merge the rest
		foreach my $region (keys %fields)
		{
			foreach my $section (keys %{$new_href->{$region}})
			{
print STDERR " + Overwrite existing {$region}{$section} with new ....\n" if $DEBUG ;

				## Just overwrite
				foreach my $field (keys %{$new_href->{$region}{$section}})
				{
					$old_href->{$region}{$section}{$field} = $new_href->{$region}{$section}{$field} ;
				}
			}
		}
	}

	$old_href = $new_href if (!$old_href) ;

print STDERR Data::Dumper->Dump(["merge_scan_freqs END - Scan info [$scan_info_href]=", $scan_info_href]) if $DEBUG>=5 ;

print STDERR "merge_scan_freqs() - DONE\n" if $DEBUG ;

	return $old_href ;
}


#----------------------------------------------------------------------
sub _merge_tsid
{
	my ($new_href, $old_href, $options_href, $verbose, $scan_info_href, $new_old_info_href) = @_ ;

	$scan_info_href->{'chans'} ||= {} ;
	$scan_info_href->{'tsids'} ||= {} ;

print STDERR "_merge_tsid()\n" if $DEBUG ;
print STDERR Data::Dumper->Dump(["_merge_tsid()", $new_href->{'ts'}]) if $DEBUG>=2 ;


	## Compare new with old
	foreach my $tsid (keys %{$new_old_info_href->{'new'}{'tsid'}})
	{
		my $new_chans = scalar(keys %{$new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}}) ;
		my $old_chans = 0 ;

		my $new_strength_href = _strength_create($new_old_info_href->{'new'}{'tsid'}{$tsid}) ;
		my $old_strength_href = _strength_create(0) ;
#		my $new_strength = $new_old_info_href->{'new'}{'tsid'}{$tsid}{'strength'} ;
#		my $old_strength = 0 ;

		my $new_freq = $new_old_info_href->{'new'}{'tsid'}{$tsid}{'freq'} ;
		my $old_freq ;

		my $overlap = 0 ;
		if ( exists($new_old_info_href->{'old'}{'tsid'}{$tsid}) )
		{
			$overlap = 1 ;
			$old_chans = scalar(keys %{$new_old_info_href->{'old'}{'tsid'}{$tsid}{'pr'}}) ;
#			$old_strength = $new_old_info_href->{'old'}{'tsid'}{$tsid}{'strength'} ;
			$old_strength_href = _strength_create($new_old_info_href->{'old'}{'tsid'}{$tsid}) ;
			$old_freq = $new_old_info_href->{'old'}{'tsid'}{$tsid}{'freq'} ;

			if ($old_freq == $new_freq)
			{
				$overlap = 0 ;
			}
		}

		$scan_info_href->{'tsids'}{$tsid} ||= {
			'comments'	=> [],
		} ;

		my $delete = 0 ;
		my $duplicate = 0 ;
		my $reason = "" ;

		if (!$overlap)
		{
			$reason = "[merge] TSID $tsid : creating new freq $new_freq (contains $new_chans chans)" ;
		}
		else
		{
			## overlap - do something
			if ($options_href->{'duplicates'})
			{
				$duplicate = 1 ;
				$reason = "[duplicate] TSID $tsid : tsid already exists (new freq $new_freq chans $new_chans, old freq $old_freq chans $old_chans), creating duplicate" ;
			}
			else
			{
				# do we overwrite based on number of channels a multiplex contains OR on the signal strength
				if (!$options_href->{'num_chans'} || ($new_chans == $old_chans))
				{

					# overwrite based on signal strength
##					if ($new_strength < $old_strength)
					if (_strength_cmp($new_strength_href, $old_strength_href) < 0)
					{
						my $new_strength_str = _strength_str($new_strength_href);
						my $old_strength_str = _strength_str($old_strength_href);

						$delete = 1 ;
#						$reason = "[overlap] TSID $tsid : new freq $new_freq strength $new_strength ($new_chans chans) < existing freq $old_freq strength $old_strength ($old_chans chans) - new freq ignored" ;
						$reason = "[overlap] TSID $tsid : new freq $new_freq strength $new_strength_str ($new_chans chans) < existing freq $old_freq strength $old_strength_str ($old_chans chans) - new freq ignored" ;
					}
					else
					{
						my $new_strength_str = _strength_str($new_strength_href);
						my $old_strength_str = _strength_str($old_strength_href);

#						$reason = "[overlap] TSID $tsid : new freq $new_freq strength $new_strength >= existing freq $old_freq strength $old_strength - using new freq" ;
						$reason = "[overlap] TSID $tsid : new freq $new_freq strength $new_strength_str ($new_chans chans) >= existing freq $old_freq strength $old_strength_str ($old_chans chans) - using new freq" ;
					}
				}

				# compare number of channels
				elsif ($new_chans < $old_chans)
				{
					$delete = 1 ;
					$reason = "[overlap] TSID $tsid : new freq $new_freq has only $new_chans chans (existing freq $old_freq has $old_chans chans) - new freq ignored" ;
				}
				else
				{
					$reason = "[overlap] TSID $tsid : new freq $new_freq has $new_chans chans (existing freq $old_freq has $old_chans chans) - using new freq" ;
				}
			}
		}

		## delete if required
		if ($delete)
		{
			delete $new_href->{'ts'}{$tsid} ;

			foreach my $pnr (keys %{$new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}} )
			{
				my $chan = $new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}{$pnr} ;
				$scan_info_href->{'chans'}{$chan} ||= {
					'comments'	=> [],
				} ;
				push @{$scan_info_href->{'chans'}{$chan}{'comments'}}, $reason ;

				delete $new_href->{'pr'}{$chan} ;
			}
		}
		## duplicate if required
		elsif ($duplicate)
		{
			## Create a dummy name for this tsid
			my $suffix = 'a' ;
			my $tsid_dup = "$tsid$suffix" ;
			while (exists($new_old_info_href->{'old'}{'tsid'}{$tsid_dup}))
			{
				++$suffix ;
				$tsid_dup = "$tsid$suffix" ;
			}
			$reason .= " TSID $tsid_dup" ;


			## rename tsid

			# ts
			my $tsid_href = delete $new_href->{'ts'}{$tsid} ;
			$new_href->{'ts'}{$tsid_dup} = $tsid_href ;
			$new_href->{'ts'}{$tsid_dup}{'tsid'} = $tsid_dup ;

			# pr
			foreach my $pnr (keys %{$new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}} )
			{
				my $chan = $new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}{$pnr} ;
				$scan_info_href->{'chans'}{$chan} ||= {
					'comments'	=> [],
				} ;
				push @{$scan_info_href->{'chans'}{$chan}{'comments'}}, $reason ;

				$new_href->{'pr'}{$chan}{'tsid'} = $tsid_dup ;
			}

			# lcn
			my $lcn_href = delete $new_href->{'lcn'}{$tsid} ;
			$new_href->{'lcn'}{$tsid_dup} = $lcn_href ;

			## rename chan

			# pr
			foreach my $pnr (keys %{$new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}} )
			{
				my $chan = $new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}{$pnr} ;

				my $count = 1 ;
				my $chan_dup = "$chan ($count)";
				while (exists($new_old_info_href->{'old'}{'pr'}{$chan_dup}))
				{
					++$count ;
					$chan_dup = "$chan ($count)";
				}

				push @{$scan_info_href->{'chans'}{$chan}{'comments'}}, "[duplicate] Renamed $chan to $chan_dup" ;

				my $chan_href = delete $new_href->{'pr'}{$chan} ;
				$new_href->{'pr'}{$chan_dup} = $chan_href  ;
				$new_href->{'pr'}{$chan_dup}{'name'} = $chan_dup  ;
			}


print STDERR " + duplicate TSID\n" if $DEBUG ;
print STDERR Data::Dumper->Dump(["After tsid rename ", $new_href]) if $DEBUG>=2 ;

		}
		else
		{
			## ok to copy
			foreach my $pnr (keys %{$new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}} )
			{
				my $chan = $new_old_info_href->{'new'}{'tsid'}{$tsid}{'pr'}{$pnr} ;
				$scan_info_href->{'chans'}{$chan} ||= {
					'comments'	=> [],
				} ;
				push @{$scan_info_href->{'chans'}{$chan}{'comments'}}, $reason ;
			}
		}

		# update TSID debug info
		push @{$scan_info_href->{'tsids'}{$tsid}{'comments'}}, $reason ;
	}

	## Do merge
	foreach my $tsid (keys %{$new_href->{'ts'}})
	{
		## Just overwrite
		foreach my $field (keys %{$new_href->{'ts'}{$tsid}})
		{
			$old_href->{'ts'}{$tsid}{$field} = $new_href->{'ts'}{$tsid}{$field} ;
		}
	}

}


#----------------------------------------------------------------------
sub _merge_chan
{
	my ($new_href, $old_href, $options_href, $verbose, $scan_info_href, $new_old_info_href) = @_ ;

	$scan_info_href->{'chans'} ||= {} ;
	$scan_info_href->{'tsids'} ||= {} ;

print STDERR "_merge_chan()\n" if $DEBUG ;
print STDERR Data::Dumper->Dump(["_merge_chan()", $new_href->{'pr'}]) if $DEBUG>=2 ;

	## Do merge
	foreach my $chan (keys %{$new_href->{'pr'}})
	{
		## Check for channel rename
		my $tsid = $new_href->{'pr'}{$chan}{'tsid'} ;
		my $pnr = $new_href->{'pr'}{$chan}{'pnr'} ;

print STDERR " + check {$tsid-$pnr} = $chan \n" if $DEBUG ;

		if (exists($new_old_info_href->{'old'}{'tsid-pnr'}{"$tsid-$pnr"}) && ($new_old_info_href->{'old'}{'tsid-pnr'}{"$tsid-$pnr"} ne $chan))
		{
			# Rename
			my $old_chan = $new_old_info_href->{'old'}{'tsid-pnr'}{"$tsid-$pnr"} ;
			push @{$scan_info_href->{'chans'}{$chan}{'comments'}}, "[merge] channel renamed from \"$old_chan\" to \"$chan\" " ;
			delete $old_href->{'pr'}{$old_chan} ;
print STDERR " + + delete $old_chan \n" if $DEBUG ;
		}

		## Check for channel TSID change
		my $overlap = 0 ;
		if (exists($old_href->{'pr'}{$chan}))
		{
			$overlap = 1 ;
			if ($new_href->{'pr'}{$chan}{'tsid'} eq $old_href->{'pr'}{$chan}{'tsid'})
			{
				$overlap = 0 ;
			}
		}

		$scan_info_href->{'chans'}{$chan} ||= {
			'comments'	=> [],
		} ;

		my $reason ;
		my $copy_chan = $chan ;
		if (!$overlap)
		{
			$reason = "[merge] creating new channel info" ;
		}
		else
		{
			## overlap - do something
			if ($options_href->{'duplicates'})
			{
				# duplicate
				$reason = "[duplicate] Channel $chan already exists (new TSID $new_href->{'pr'}{$chan}{'tsid'}, old TSID $old_href->{'pr'}{$chan}{'tsid'}), creating duplicate" ;


				my $count = 1 ;
				$copy_chan = "$chan ($count)";
				while (exists($old_href->{'pr'}{$copy_chan}))
				{
					++$count ;
					$copy_chan = "$chan ($count)";
				}

				$reason .= " New channel name $copy_chan" ;
			}
			else
			{
				# overwrite
				$reason = "[overlap] overwriting existing channel info with new (old: TSID $old_href->{'pr'}{$chan}{tsid})" ;
			}
		}
		push @{$scan_info_href->{'chans'}{$chan}{'comments'}}, $reason ;


		## Now overwrite
		foreach my $field (keys %{$new_href->{'pr'}{$chan}})
		{
			$old_href->{'pr'}{$copy_chan}{$field} = $new_href->{'pr'}{$chan}{$field} ;
		}
		$old_href->{'pr'}{$copy_chan}{'name'} = $copy_chan ;
	}

}




#----------------------------------------------------------------------
sub _scan_info
{
	my ($scan_href) = @_ ;

	## Get info on existing
	my %tsid_map ;
	foreach my $chan (keys %{$scan_href->{'pr'}})
	{
		my $tsid = $scan_href->{'pr'}{$chan}{'tsid'} ;
		my $pnr = $scan_href->{'pr'}{$chan}{'pnr'} ;
		$tsid_map{"$tsid-$pnr"} = $chan ;
	}

	## Various ways of looking at tsid info
	my %ts_info ;
	foreach my $tsid (keys %{$scan_href->{'ts'}})
	{
		my $freq = $scan_href->{'ts'}{$tsid}{'frequency'} ;
		$ts_info{$tsid} = {
			'pr'		=> {},
			'freq'		=> $scan_href->{'ts'}{$tsid}{'frequency'},
			'strength'	=> $scan_href->{'ts'}{$tsid}{'strength'},
			'snr'	=> $scan_href->{'ts'}{$tsid}{'snr'},
			'ber'	=> $scan_href->{'ts'}{$tsid}{'ber'},
		} ;
	}
	foreach my $chan (keys %{$scan_href->{'pr'}})
	{
		my $tsid = $scan_href->{'pr'}{$chan}{'tsid'} ;
		my $pnr = $scan_href->{'pr'}{$chan}{'pnr'} ;
		$ts_info{$tsid}{'pr'}{$pnr} = $chan ;
	}


	## Various ways of looking at channel info
	my %chan_info ;
	foreach my $chan (keys %{$scan_href->{'pr'}})
	{
		my $tsid = $scan_href->{'pr'}{$chan}{'tsid'} ;
		$chan_info{$chan} = $tsid ;
	}

	my %info = (
		'tsid-pnr'	=> \%tsid_map,
		'tsid'		=> \%ts_info,
		'chan'		=> \%chan_info,
	) ;
	return \%info ;
}




#----------------------------------------------------------------------
# Split the search path & expand all the directories to absolute paths
#
sub _expand_search_path
{
	my ($search_path) = @_ ;

	my @dirs = split /:/, $search_path ;
	foreach my $d (@dirs)
	{
		# Replace any '~' with $HOME
		$d =~ s/~/\$HOME/g ;

		# Now replace any vars with values from the environment
		$d =~ s/\$(\w+)/$ENV{$1}/ge ;

		# Ensure path is clean
		$d = File::Spec->rel2abs($d) ;
	}

	return @dirs ;
}

#----------------------------------------------------------------------

=item B

Find directory to read from - first readable directory in search path

=cut

sub read_dir
{
	my ($search_path) = @_ ;

	my @dirs = _expand_search_path($search_path) ;
	my $dir ;

	foreach my $d (@dirs)
	{
		my $found=1 ;
		foreach my $region (keys %FILES)
		{
			if ($FILES{$region}{'required'})
			{
				$found=0 if (! -f  "$d/$FILES{$region}{'file'}") ;
			}
		}

		if ($found)
		{
			$dir = $d ;
			last ;
		}
	}

	print STDERR "Searched $search_path : read dir=".($dir?$dir:"")."\n" if $DEBUG ;

	return $dir ;
}

#----------------------------------------------------------------------

=item B

Find directory to write to - first writeable directory in search path

=cut

sub write_dir
{
	my ($search_path) = @_ ;

	my @dirs = _expand_search_path($search_path) ;
	my $dir ;

	print STDERR "Find dir to write to from $search_path ...\n" if $DEBUG ;

	foreach my $d (@dirs)
	{
		my $found=1 ;

		print STDERR " + processing $d\n" if $DEBUG ;

		# See if dir exists
		if (!-d $d)
		{
			# See if this user can create the dir
			eval {
				mkpath([$d], $DEBUG, 0755) ;
			};
			$found=0 if $@ ;

			print STDERR " + $d does not exist - attempt to mkdir=$found\n" if $DEBUG ;
		}

		if (-d $d)
		{
			print STDERR " + $d does exist ...\n" if $DEBUG ;

			# See if this user can write to the dir
			foreach my $region (keys %FILES)
			{
				if (open my $fh, ">>$d/$FILES{$region}{'file'}")
				{
					close $fh ;

					print STDERR " + + Write to $d/$FILES{$region}{'file'} succeded\n" if $DEBUG ;
				}
				else
				{
					print STDERR " + + Unable to write to $d/$FILES{$region}{'file'} - aborting this dir\n" if $DEBUG ;

					$found = 0;
					last ;
				}
			}
		}

		if ($found)
		{
			$dir = $d ;
			last ;
		}
	}

	print STDERR "Searched $search_path : write dir=".($dir?$dir:"")."\n" if $DEBUG ;

	return $dir ;
}


#============================================================================================

=back

=head3 TSID config file (dvb-ts) read/write

=over 4

=cut


#----------------------------------------------------------------------

=item B

Read the transponder settings file of the form:

	[4107]
	name = Oxford/Bexley
	frequency = 578000000
	bandwidth = 8
	modulation = 16
	hierarchy = 0
	code_rate_high = 34
	code_rate_low = 34
	guard_interval = 32
	transmission = 2

=cut

sub read_dvb_ts
{
	my ($fname) = @_ ;

	my %dvb_ts ;
	open my $fh, "<$fname" or die "Error: Unable to read $fname : $!" ;

	my $line ;
	my $tsid ;
	while(defined($line=<$fh>))
	{
		chomp $line ;
		next if $line =~ /^\s*#/ ; # skip comments

		if ($line =~ /\[([\da-z]+)\]/i)
		{
			$tsid=$1;
		}
		elsif ($line =~ /(\S+)\s*=\s*(\S+)/)
		{
			if ($tsid)
			{
				$dvb_ts{$tsid}{$1} = $2 ;
			}
		}
		elsif ($line =~ /(\S+)\s*=/)
		{
			# skip empty entries
		}
		else
		{
			$tsid = undef ;
		}
	}
	close $fh ;

	return \%dvb_ts ;
}

#----------------------------------------------------------------------

=item B

Read the transponder settings file comments section, if present, containing the
frequency file information used during the scan. The values are in "VDR" format:

	# VDR freq      bw   fec_hi fec_lo mod   transmission-mode guard-interval hierarchy inversion

For example, the frequency file format:

	# T 578000000 8MHz 2/3    NONE   QAM64 2k                1/32           NONE

will be saved as:

	# VDR 578000000 8  23     0      64    2                 32             0			0

=cut

sub read_dvb_ts_freqs
{
	my ($fname) = @_ ;

print STDERR "read_dvb_ts_freqs($fname)\n" if $DEBUG>=5 ;

	my %dvb_ts_freqs = () ;
	open my $fh, "<$fname" or die "Error: Unable to read $fname : $!" ;

	my $line ;
	while(defined($line=<$fh>))
	{
		chomp $line ;
		next unless $line =~ /^\s*#/ ; # skip non-comments

print STDERR " + line $line\n" if $DEBUG>=5 ;

		## Parse line
		if ($line =~ m%^\s*#\s*VDR\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)%i)
		{
			my $freq = Linux::DVB::DVBT::dvb_round_freq($1) ;

			if (exists($dvb_ts_freqs{$freq}))
			{
				print STDERR "Note: frequency $freq Hz already seen, skipping\n" ;
				next ;
			}

print STDERR " + + add $freq\n" if $DEBUG>=5 ;

			$dvb_ts_freqs{$freq} = {
				frequency => $freq,
				bandwidth => $2,
				code_rate_high => $3,
				code_rate_low => $4,
				modulation => $5,
				transmission => $6,
				guard_interval => $7,
				hierarchy => $8,
				inversion => $9,
			} ;
		}

	}
	close $fh ;

print STDERR Data::Dumper->Dump(["read_dvb_ts_freqs - href=", \%dvb_ts_freqs]) if $DEBUG>=5 ;

	return \%dvb_ts_freqs ;
}


#----------------------------------------------------------------------

=item B

Write transponder config information

=cut

sub write_dvb_ts
{
	my ($fname, $href, $freqs_href) = @_ ;

	open my $fh, ">$fname" or die "Error: Unable to write $fname : $!" ;

print STDERR Data::Dumper->Dump(["write_dvb_ts - href=", $href, "freqs=", $freqs_href]) if $DEBUG>=5 ;

	## Save frequency list first (if available)
	if ($freqs_href && (keys %$freqs_href))
	{
		#		# VDR freq      bw   fec_hi fec_lo mod   transmission-mode guard-interval hierarchy inversion
		#
		#		# VDR 578000000 8    23     0      64    2                 32             0         0
		#
		print $fh "##    freq bw fec_hi fec_lo mod transmission-mode guard-interval hierarchy inversion\n" ;
		foreach my $freq (sort {$a <=> $b} keys %$freqs_href)
		{
			my $tuning_href = $freqs_href->{$freq} ;
			print $fh "# VDR " ;
			foreach my $field (qw/
				frequency
				bandwidth
				code_rate_high
				code_rate_low
				modulation
				transmission
				guard_interval
				hierarchy
				inversion
			/)
			{
				printf $fh "%d ", $tuning_href->{$field} ;
			}
			print $fh "\n" ;
		}
	}

	# Write config information
	#
	#	'ts' =>
	#	      4107 =>
	#	        { # HASH(0x83241b8)
	#	          bandwidth => 8,
	#	          code_rate_hp => 34,         code_rate_high
	#	          code_rate_lp => 34,         code_rate_low
	#	          constellation => 16,        modulation
	#	          frequency => 578000000,
	#	          guard => 32,                guard_interval
	#	          hierarchy => 0,
	#	          net => Oxford/Bexley,
	#	          transmission => 2,
	#	          tsid => 4107,
	#	        },
	#
	#[4107]
	#name = Oxford/Bexley
	#frequency = 578000000
	#bandwidth = 8
	#modulation = 16
	#hierarchy = 0
	#code_rate_high = 34
	#code_rate_low = 34
	#guard_interval = 32
	#transmission = 2
	#
	#
	foreach my $section (sort {$a <=> $b} keys %$href)
	{
		print $fh "[$section]\n" ;
		foreach my $field (sort keys %{$href->{$section}})
		{
			my $val = $href->{$section}{$field} ;
			if ($val =~ /\S+/)
			{
				print $fh "$field = $val\n" ;
			}
		}
		print $fh "\n" ;
	}

	close $fh ;
}


#============================================================================================

=back

=head3 Channels config file (dvb-pr) read/write

=over 4

=cut


#----------------------------------------------------------------------

=item B

Read dvb-pr - channel information - of the form:

	[4107-4171]
	video = 600
	audio = 601
	audio_details = eng:601 eng:602
	type = 1
	net = BBC
	name = BBC ONE

=cut

sub read_dvb_pr
{
	my ($fname) = @_ ;

	my %dvb_pr ;
	open my $fh, "<$fname" or die "Error: Unable to read $fname : $!"  ;

	my $line ;
	my $pnr ;
	my $tsid ;
	while(defined($line=<$fh>))
	{
		chomp $line ;
		next if $line =~ /^\s*#/ ; # skip comments

		if ($line =~ /\[([\da-z]+)\-([\d]+)\]/i)
		{
			($tsid, $pnr)=($1,$2);
		}
		elsif ($line =~ /(\S+)\s*=\s*(\S+.*)/)
		{
			if ($pnr && $tsid)
			{
				$dvb_pr{"$tsid-$pnr"}{$1} = $2 ;

				# ensure tsid & pnr are in the hash
				$dvb_pr{"$tsid-$pnr"}{'tsid'} = $tsid ;
				$dvb_pr{"$tsid-$pnr"}{'pnr'} = $pnr ;
			}
		}
		elsif ($line =~ /(\S+)\s*=/)
		{
			# skip empty entries
		}
		else
		{
			$pnr = undef ;
			$tsid = undef ;
		}
	}
	close $fh ;

	# Make channel name the first key
	my %chans ;
	foreach (keys %dvb_pr)
	{
		# handle chans with no name
		my $name = $dvb_pr{$_}{'name'} || $_ ;
		$chans{$name} = $dvb_pr{$_} ;
	}

	return \%chans ;
}

#----------------------------------------------------------------------

=item B

Write program config file.

=cut

sub write_dvb_pr
{
	my ($fname, $href) = @_ ;

	open my $fh, ">$fname" or die "Error: Unable to write $fname : $!" ;

	# Write config information
	#
	#	'pr' =>
	#	      BBC ONE =>
	#	        { # HASH(0x8327848)
	#	          a_pid => 601,                   audio
	#	          audio => eng:601 eng:602,       audio_details
	#	          ca => 0,
	#	          name => "BBC ONE",
	#	          net => BBC,
	#	          p_pid => 4171,                  -N/A-
	#	          pnr => 4171,
	#	          running => 4,
	#	          t_pid => 0,                     teletext
	#	          tsid => 4107,
	#	          type => 1,
	#	          v_pid => 600,                   video
	#	          version => 26,                  -N/A-
	#	        },
	#
	#[4107-4171]
	#video = 600
	#audio = 601
	#audio_details = eng:601 eng:602
	#type = 1
	#net = BBC
	#name = BBC ONE
	#
	foreach my $section (sort {
		$href->{$a}{'tsid'} <=> $href->{$b}{'tsid'}
		||
		$href->{$a}{'pnr'} <=> $href->{$b}{'pnr'}
	} keys %$href)
	{
		print $fh "[$href->{$section}{tsid}-$href->{$section}{pnr}]\n" ;
		foreach my $field (sort keys %{$href->{$section}})
		{
			my $val = $href->{$section}{$field} ;
			if ($val =~ /\S+/)
			{
				print $fh "$field = $val\n" ;
			}
		}
		print $fh "\n" ;
	}

	close $fh ;
}


#============================================================================================

=back

=head3 Channel names aliases config file (dvb-aliases) read/write

=over 4

=cut

#----------------------------------------------------------------------

=item B

Read dvb-aliases - channel names aliases - of the form:

	FIVE = Channel 5

=cut

sub read_dvb_aliases
{
	my ($fname) = @_ ;

	my %dvb_aliases ;

#print STDERR "read_dvb_aliases($fname)\n" ;

	if (-f $fname)
	{
		open my $fh, "<$fname" or die "Error: Unable to read $fname : $!"  ;

		my $line ;
		while(defined($line=<$fh>))
		{
			chomp $line ;
			next if $line =~ /^\s*#/ ; # skip comments
			$line =~ s/\s+$// ;
			$line =~ s/^\s+// ;
#	print STDERR "!! $line !!\n" ;

			if ($line =~ /(\S+[^=]+)\s*=\s*(\S+[^=]+)\s*/)
			{
				my ($from, $to) = ($1, $2) ;

				$from =~ s/\s+$// ;

				$dvb_aliases{$from} = $to ;
#	print STDERR " + <$from> = <$to>\n" ;
			}
		}
		close $fh ;

	}
#print STDERR "read_dvb_aliases - done\n" ;

	return \%dvb_aliases ;
}


#----------------------------------------------------------------------

=item B

Write channel names aliases config file.

=cut

sub write_dvb_aliases
{
	my ($fname, $href) = @_ ;

	open my $fh, ">$fname" or die "Error: Unable to write $fname : $!" ;

	# Write config information
	#
	#	'aliases' =>
	#	      "FIVE" => "Channel 5"
	#
	#   FIVE = Channel 5
	#
	foreach my $from (sort keys %$href)
	{
		my $val = $href->{$from} ;
		if ($val =~ /\S+/)
		{
			print $fh "$from = $val\n" ;
		}
	}

	close $fh ;
}


#============================================================================================

# TSID strength/snr/ber

#----------------------------------------------------------------------
sub _strength_create
{
	my ($href) = @_ ;

	my $strength_href = {
		'strength'	=> 0,
		'snr'		=> 0,
		'ber'		=> undef,

		'use'		=> undef,
	} ;

print STDERR "_strength_create()\n" if $DEBUG ;

	if (ref($href) eq 'HASH')
	{
		foreach my $field (qw/strength snr ber/)
		{
print STDERR " + $field = $href->{$field}\n" if $DEBUG ;

			$strength_href->{$field} = $href->{$field} if exists($href->{$field}) ;

			# Handle special case where value reads back as all 1's
			if ($strength_href->{$field} == 0xffff)
			{
print STDERR " + + clamped dodgy value\n" if $DEBUG ;

				# treat it as a bad value
				$strength_href->{$field} = 0 ;
			}
		}

#		# Handle special case where strength reads back as all 1's
#		if ($strength_href->{'strength'} == 0xffff)
#		{
#			# treat it as a bad value
#			$strength_href->{'strength'} = 0 ;
#		}
	}

	return $strength_href ;
}


#----------------------------------------------------------------------
sub _strength_cmp
{
	my ($a_href, $b_href) = @_ ;

	## Work through the fields in order of preference
	my $use ;
	foreach my $field (qw/snr strength ber/)
	{
		if (defined($a_href->{$field}) && defined($b_href->{$field}) && ($a_href->{$field} > 0) && ($a_href->{$field} > 0))
		{
			$use = $field ;
			last ;
		}
	}

print STDERR "_strength_cmp()\n" if $DEBUG ;

	$use ||= 'strength' ;
	$a_href->{'use'} = $use ;
	$b_href->{'use'} = $use ;

	my $a_val = $a_href->{$use} ;
	my $b_val = $b_href->{$use} ;
	if ($use eq 'ber')
	{
		$a_val = 0xffff - $a_val ;
		$b_val = 0xffff - $b_val ;
	}

print STDERR " + using $use - $a_val <=> $b_val\n" if $DEBUG ;

	return $a_val <=> $b_val ;
}

#----------------------------------------------------------------------
sub _strength_str
{
	my ($href) = @_ ;

	my $str = "unset" ;
	if ($href->{'use'})
	{
		$str = "$href->{$href->{use}} ($href->{use})" ;
	}
	return $str ;
}

# ============================================================================================
# END OF PACKAGE
1;