<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!/usr/bin/perl
#
# ino711d.pl
# ==========
#
# A http server written in perl to remote control
# an Inovonics 711 RDS/RBDS Generator
#
# Version 0.1 - 6th March 2004
# Version 0.2 - 19th March 2004 - added POD
#
# By Nicholas Humfrey &lt;njh@surgeradio.co.uk&gt;
# Copyright (c) 2004 University of Southampton. All rights reserved.
# This program is free software.  You may modify and/or distribute it
# under the same terms as Perl itself.  This copyright notice
# must remain attached to the file.
#
#
# Required Debian Packages:
#
# libwww-perl
# libhtml-parser-perl
# liburi-perl
# libdevice-serialport-perl
# libtime-hires-perl
# libxml-simple-perl
#
# 
# Homepage: http://www.ecs.soton.ac.uk/~njh/ino711d/
#

use HTTP::Daemon;
use HTTP::Request;
use HTTP::Status;
use HTML::Entities;
use URI::Escape;
use XML::Simple;
use Getopt::Std;
use Device::SerialPort;
use Time::HiRes qw( time sleep alarm );

use strict;
use warnings;




## User Settings ##

my $HTTP_Host = '127.0.0.1';
my $HTTP_Port = 8080;
my $HTTP_Queue = 5;

my $Serial_Port = '/dev/ttyS1';
my $Serial_Timeout = 5;
my $Baud_Rate = 9600;

my @Allow_Hosts = (
	'127.0.0.1',	# localhost
);

## End of Settings ##




# Version Number
my $VERSION = "0.2";

# Details of the RDS fields
my $rds_field_map = {

	'VER' =&gt; {
		'name'	=&gt; 'Firmware Version',
		'type'	=&gt; 'string',
		'ro'	=&gt; 'true',
	},

	'PI' =&gt; {
		'name'	=&gt; 'Program Identification',
		'type'	=&gt; 'string',
		'len'	=&gt; '4',
	},
	
	'PS' =&gt; {
		'name'	=&gt; 'Program Service Name',
		'type'	=&gt; 'string',
		'len'	=&gt; '8',
	},
	
	'TEXT' =&gt; {
		'name'	=&gt; 'RadioText',
		'type'	=&gt; 'string',
		'len'	=&gt; '64',
	},
	
	'NUM' =&gt; {
		'name'	=&gt; 'Encoder Site Address',
		'type'	=&gt; 'number',
		'min'	=&gt; '0',
		'max'	=&gt; '1023',
	},

	'LEVEL' =&gt; {
		'name'	=&gt; 'Subcarrier Amplitude',
		'type'	=&gt; 'string',
		'ro'	=&gt; 'true',
	},
	
	'PHASE' =&gt; {
		'name'	=&gt; 'Subcarrier Phase',
		'type'	=&gt; 'number',
		'ro'	=&gt; 'true',
	},

	'RT_RATE' =&gt; {
		'name'	=&gt; 'RadioText Rate',
		'help'	=&gt; 'Set to 0 to disable RadioText',
		'type'	=&gt; 'number',
		'min'	=&gt; '0',
		'max'	=&gt; '250',
	},

	'PTY' =&gt; {
		'name'	=&gt;	'Program Type',
		'type'  =&gt;	'enum',
		'enum'	=&gt; {
			1	=&gt; 'News',
			2	=&gt; 'Current Affairs',
			3	=&gt; 'Information',
			4	=&gt; 'Sport',
			5	=&gt; 'Education',
			6	=&gt; 'Drama',
			7	=&gt; 'Culture',
			8	=&gt; 'Science',
			9	=&gt; 'Varied',
			10	=&gt; 'Pop Music',
			11	=&gt; 'Rock Music',
			12	=&gt; 'Easy Listening Music',
			13	=&gt; 'Light Classical Music',
			14	=&gt; 'Serious Classical Music',
			15	=&gt; 'Other Music',
			16	=&gt; 'Weather',
			17	=&gt; 'Finance',
			18	=&gt; 'Childrens Programmes',
			19	=&gt; 'Social Affairs',
			20	=&gt; 'Religion',
			21	=&gt; 'Phone In',
			22	=&gt; 'Travel ',
			23	=&gt; 'Leisure',
			24	=&gt; 'Jazz Music',
			25	=&gt; 'Country Music',
			26	=&gt; 'National Music',
			27	=&gt; 'Oldies Music',
			28	=&gt; 'Folk Music',
			29	=&gt; 'Documentary' }
		},
		
	'DI' =&gt; {
		'name'	=&gt;	'Decoder Information',
		'type'  =&gt;	'enum',
		'enum'	=&gt; {
			0	=&gt;	'Mono',
			1	=&gt;	'Stereo' },
		},
	
	'MS' =&gt; {
		'name'	=&gt;	'Music / Speech Switch',
		'type'  =&gt;	'enum',
		'enum'	=&gt; {
			0	=&gt;	'Primarily Speech',
			1	=&gt;	'Primarily Music' },
		},
		
	'TP' =&gt; {
		'name'	=&gt;	'Traffic Program Identification',
		'type'  =&gt;	'enum',
		'enum'	=&gt; {
			0	=&gt;	'No travel Information',
			1	=&gt;	'Regular Travel Advice' },
		},
		
	'TA' =&gt; {
		'name'	=&gt;	'Travel Announcement',
		'type'  =&gt;	'enum',
		'enum'	=&gt; {
			0	=&gt;	'Normal Broadcast',
			1	=&gt;	'Travel Announcement On-air' },
		},
};



# Force Hot output
$|=1;


## Get command line options
getopts('d');
use vars qw( $opt_d );
my $Debug      = ($opt_d ? 1 : 0);




# Create Serial Port
my $serial = serial_open( $Serial_Port, $Baud_Rate);

# Ensure we are set to ASCII mode
set_rds_value($serial, 'EBU', 0);

# Turn off echo
set_rds_value($serial, 'ECHO', 0);



# Fetch current values
foreach my $field (keys %$rds_field_map) {
	my $value = get_rds_value($serial, $field);
	$rds_field_map-&gt;{$field}-&gt;{'value'} = $value;
#	print "$field = $value\n";
}



# Create the HTTP Daemon
my $d = HTTP::Daemon-&gt;new(
 	LocalAddr=&gt;$HTTP_Host,	# Address to listen on
 	LocalPort=&gt;$HTTP_Port,	# Port to listen on
 	Listen=&gt;$HTTP_Queue,	# Queue size
 	Reuse=&gt;1 ) || die;


while (my $c = $d-&gt;accept) {
	my $r = $c-&gt;get_request;
	
	print localtime().": Handling request from ".$c-&gt;peerhost()." for ".$r-&gt;url."\n";

	# Is the host authorised ?
	if (!grep($c-&gt;peerhost() eq $_, @Allow_Hosts)) {
		print "Host isn't authorised: ".$c-&gt;peerhost()."\n";
		$c-&gt;send_error(RC_FORBIDDEN);
		
	} else {
	
		# We only handle GET requests
		if ($r-&gt;method ne 'GET') {
			print "Method isn't implemented: ".$r-&gt;method()."\n";
			$c-&gt;send_error(RC_NOT_IMPLEMENTED);
		
		} else {
			if ($r-&gt;url-&gt;path eq "/") { handle_status_request( $c ); }
			elsif ($r-&gt;url-&gt;path eq "/edit") { handle_edit_request( $c, $r-&gt;url-&gt;query ); }
			elsif ($r-&gt;url-&gt;path eq "/set") { handle_set_request( $c, $r-&gt;url-&gt;query ); }
			elsif ($r-&gt;url-&gt;path eq "/status.xml") { handle_xml_request( $c ); }
			else {
				$c-&gt;send_error(RC_NOT_FOUND);
			}
		}
	
	}

	$c-&gt;close;
	undef($c);
}

$d-&gt;close();


# Turn Echo back on and disconnect
set_rds_value($serial, 'ECHO', 1);
serial_close( $serial );




sub create_html_header {
	my $title = shift;
	my $content;
	
	$content .= '&lt;!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"';
	$content .= ' "http://www.w3.org/TR/html4/loose.dtd"&gt;';
	$content .= '&lt;HTML&gt;&lt;HEAD&gt;&lt;TITLE&gt;'.$title.'&lt;/TITLE&gt;&lt;/HEAD&gt;';
	$content .= '&lt;body bgcolor="#ffffff"&gt;&lt;H1&gt;'.$title.'&lt;/H1&gt;';

	return $content;
}


sub create_html_footer {
	my $content;
	
	$content .= '&lt;HR&gt;&lt;I&gt;ino711d.pl version '.$VERSION;
	$content .= ' by Nicholas Humfrey&lt;/I&gt;';
	$content .= '&lt;/BODY&gt;&lt;/HTML&gt;';
	
	return $content;
}


sub handle_status_request {
	my $client = shift;
	my $response = HTTP::Response-&gt;new( RC_OK );

	my $content = create_html_header('ino711d: Status');
	$content .= '&lt;table border="1" cellspacing="0" cellpadding="2"&gt;';

	my $c=0;
	foreach my $key (keys %$rds_field_map) {
		my $field = $rds_field_map-&gt;{$key};
		
		if ($c%2)	{ $content .= '&lt;TR bgcolor="#f5f5ff"&gt;'; }
		else		{ $content .= '&lt;TR bgcolor="#ffffff"&gt;'; }
		
		$content .= "&lt;TD&gt;&lt;B&gt;".$key."&lt;/B&gt;&lt;BR&gt;";
		$content .= "&lt;FONT SIZE='-1'&gt;".$field-&gt;{'name'}."&lt;/FONT&gt;&lt;/TD&gt;";
		
		$content .= '&lt;TD&gt;'.$field-&gt;{'value'};
		if ($field-&gt;{'type'} eq 'enum') {
			$content .= " (".$field-&gt;{'enum'}-&gt;{$field-&gt;{'value'}}.")";
		}
		$content .= '&lt;/TD&gt;&lt;td width="50" align="center"&gt;';
		
		$content .= '&lt;A HREF="/edit?'.$key.'"&gt;Edit&lt;/A&gt;'
		unless (defined $field-&gt;{'ro'});
		
		$content .= '&lt;/TD&gt;&lt;/TR&gt;';
		$c++;
	}

	$content .= '&lt;/TABLE&gt;&lt;/FORM&gt;&lt;BR&gt;&lt;BR&gt;';
	$content .= 'This information is also available as XML ';
	$content .= '&lt;A HREF="/status.xml"&gt;here&lt;/A&gt;.';
	$content .= create_html_footer();

	$response-&gt;content( $content );
	$response-&gt;content_type('text/html');
	$client-&gt;send_response( $response );
}

sub handle_edit_request {
	my ($client, $key) = @_;
	my $field = $rds_field_map-&gt;{$key};
	
	# Does the field exist ?
	if (!defined $field) {
		$client-&gt;send_error(RC_BAD_REQUEST);
		return;
	}
	
	
	my $response = HTTP::Response-&gt;new( RC_OK );
	my $content = create_html_header('ino711d: Edit Setting');
	
	$content .= '&lt;FORM action="/set" method="get"&gt;';
	$content .= '&lt;table border="1" cellspacing="0" cellpadding="6"&gt;';
	$content .= '&lt;TR bgcolor="#f5f5ff"&gt;&lt;TD&gt;&lt;FONT SIZE="+1"&gt;&lt;B&gt;'.$key.'&lt;/B&gt;&lt;/FONT&gt; - ';
	$content .= $field-&gt;{'name'}.'&lt;BR&gt;&lt;FONT SIZE="-1"&gt;';
	$content .= $field-&gt;{'help'}.'&lt;/font&gt;&lt;/TD&gt;&lt;/TR&gt;';

	$content .= '&lt;TR&gt;&lt;TD ALIGN="center" HEIGHT="50"&gt;';
	if ($field-&gt;{'type'} eq 'string') {
		my $value = encode_entities( $field-&gt;{'value'} );
		$content .= '&lt;INPUT TYPE="text" '.
					'SIZE="'.$field-&gt;{'len'}.'" '.
					'MAXLENGTH="'.$field-&gt;{'len'}.'" '.
					'NAME="'.$key.'" '.
					'VALUE="'.$value.'"&gt;';
	} elsif ($field-&gt;{'type'} eq 'number') {
		my $value = $field-&gt;{'value'};
		$value =~ s/[^\d\-\.]//g;
		$content .= '&lt;FONT SIZE="-1"&gt;Min='.$field-&gt;{'min'}.'&lt;/FONT&gt;&lt;BR&gt;';
		$content .= '&lt;INPUT TYPE="text" '.
					'SIZE="8" MAXLENGTH="8" '.
					'NAME="'.$key.'" '.
					'VALUE="'.$value.'"&gt;';
		$content .= '&lt;BR&gt;&lt;FONT SIZE="-1"&gt;Max='.$field-&gt;{'max'}.'&lt;/FONT&gt;';
	} elsif ($field-&gt;{'type'} eq 'enum') {
		my $enum = $field-&gt;{'enum'};
		$content .= '&lt;SELECT NAME="'.$key.'"&gt;';
		foreach my $value ( keys %$enum ) {
			$content .= '&lt;OPTION VALUE="'.$value.'"';
			$content .= " SELECTED" if ($field-&gt;{'value'} eq $value);
			$content .= '&gt;'.$enum-&gt;{$value}.'&lt;/OPTION&gt;';
		}
		$content .= '&lt;/SELECT&gt;';
	} else {
		$content .= "&lt;B&gt;Unsupported field type ($field-&gt;{'type'})&lt;/B&gt;";
	}
	$content .= "&lt;/TD&gt;&lt;/TR&gt;";
	
	$content .= '&lt;TR bgcolor="#f5f5ff"&gt;&lt;TD ALIGN="right"&gt;';
	$content .= '&lt;INPUT TYPE="reset" ID="Reset"&gt; ';
	$content .= '&lt;INPUT TYPE="submit" ID="Submit"&gt; ';
	$content .= '&lt;/TD&gt;&lt;/TR&gt;&lt;/TABLE&gt;&lt;/FORM&gt;';
	$content .= '&lt;BR&gt;&lt;A HREF="/"&gt;Back Home&lt;/A&gt;';
	$content .= create_html_footer();
	
	
	$response-&gt;content( $content );
	$response-&gt;content_type('text/html');
	$client-&gt;send_response( $response );
}

sub handle_set_request {
	my ($client, $query) = @_;
	
	# Decode and seperate the field and value
	$query =~ s/\+/ /g;
	$query = uri_unescape($query);
	my ($key, $value) = ($query =~ /^(\w+)=(.+)$/);
	my $field = $rds_field_map-&gt;{$key};
	
	# Does the field exist ?
	if (!defined $field or !defined $value) {
		$client-&gt;send_error(RC_BAD_REQUEST);
		print $client "Invalid parameters";
		return;
	}
	
	# Basic validation based on type
	my $invalid;
	if ($field-&gt;{'type'} eq 'string') {
		if (length($value)&gt;$field-&gt;{'len'}) {
			$invalid = "String too long.";
		}
	} elsif ($field-&gt;{'type'} eq 'number') {
		if ($value =~ /[^\d\.\-]/) {
			$invalid = "Not a number";
		} elsif ($value &lt; $field-&gt;{'min'}) {
			$invalid = "Value is below minimum.";
		} elsif ($value &gt; $field-&gt;{'max'}) {
			$invalid = "Value is above maximum.";
		}
	} elsif ($field-&gt;{'type'} eq 'enum') {
		if (!defined $field-&gt;{'enum'}-&gt;{$value}) {
			$invalid = "Not a valid value in enum.";
		}
	}
	
	
	# More validation
	if ($key eq 'PI') {
		$value =~ tr/a-z/A-Z/;
		if ($value =~ /[^A-F0-9]/) {
			$invalid = "Not a valid hexadecimal";
		}
	}
	
	# Did something look invalid ?
	if ($invalid) {
		$client-&gt;send_error( RC_BAD_REQUEST );
		print $client $invalid;
		return;
	} else {
	
		# Set the new value
		my $result = set_rds_value($serial, $key, $value);
		if ($result) {
			$client-&gt;send_error( RC_INTERNAL_SERVER_ERROR );
			print $client "Failed to set value on RDS box";
			warn "Failed to set $key=$value.\n";
			return;
		}
		
		# It seems to take a bit of time to update
		sleep 0.6;
		
		# Get new value
		my $new_value = get_rds_value( $serial, $key );
		if (!defined $new_value) {
			$client-&gt;send_error( RC_INTERNAL_SERVER_ERROR );
			print $client "Failed to fetch new value from RDS box";
			return;
		} else {
			$field-&gt;{'value'} = $new_value;
		}

	}


	# Display Success message to client
	my $response = HTTP::Response-&gt;new( RC_OK );
	my $content = create_html_header('ino711d: Set Success');
	$content .= "&lt;P&gt;$key = $field-&gt;{'value'}&lt;/P&gt;";
	$content .= "&lt;A HREF='/'&gt;Back Home&lt;/A&gt;";
	$content .= create_html_footer();
	$response-&gt;content( $content );
	$response-&gt;content_type('text/html');
	$client-&gt;send_response( $response );
}


sub handle_xml_request {
	my $client = shift;
	my $response = HTTP::Response-&gt;new( RC_OK );
	
	my $hashref = {};
	foreach my $key (keys %$rds_field_map) {
		$hashref-&gt;{$key}-&gt;[0] = $rds_field_map-&gt;{$key}-&gt;{'value'};
	}
	
	my $xml = XML::Simple::XMLout( $hashref );
	$response-&gt;content( $xml );
	$response-&gt;content_type('text/xml');
	$client-&gt;send_response( $response );
}


# Get a setting on the RDS encoder
#
# Returns value or undef if unsuccessful
#
sub get_rds_value {
	my ($serial, $field) = @_;

	# Verify the field name
	warn "Field name does not look valid: $field\n"
	unless ($field =~ /^\w+$/);

	# Send command
	serial_write( $serial, "$field?" );
	
	# Get response
	my $response = serial_read( $serial );


	# Regualar expressions to recognise various responses
	my $regexp = '\r\n(\f?)(.+)\r\n';
	if ($field eq 'TA') {
		$regexp = '\r\nSW_TA=(\d+)  TA=(\d+)\r';
	} elsif ($field eq 'RT_RATE') {
		$regexp = '(RT_RATE)=(\d+)\r\n\r\n(.+)\r\n';
	} elsif ($field eq 'RT') {
		$regexp = '(RT=)(\d+)\r\n\r\n';
	} elsif ($field eq 'NUM') {
		$regexp = '\r\n(NUM=)(\d+)\r\n';
	} elsif ($field eq 'LEVEL') {
		$regexp = '\r\n(LEVEL=)(.+)\r\n';
	} elsif ($field eq 'PHASE') {
		$regexp = '\r\n(PHASE=)(\d+)\r\n';
	}

	# Check the response
	if ($response =~ /$regexp/) {
		# Valid response
		print "Valid response: $field=$2.\n\n" if ($Debug);
		return $2;
	} else {
		warn "Got invalid response to request for '$field'.\n";
		return undef;
	}
}



# Change a setting on the RDS encoder
#
# Returns:
#	0 if successful
#	1 if unsuccessful
#
sub set_rds_value {
	my ($serial, $field, $value) = @_;
	my $command = "$field=$value";
	
	# Verify the field name
	warn "Field name does not look valid: $field\n"
	unless ($field =~ /^\w+$/);

	# Send command
	serial_write( $serial, $command );
	
	# Get response
	my $response = serial_read( $serial );
	
	# RDS box returns '+' when successful
	if ($response =~ /(\+\r)(\n?)$/) {
		print "Response successful.\n\n" if ($Debug);
		return 0;
	} else {
		$response =~ s/\s//g;
		warn "Unsucessful response to command ($command): $response\n";
		return 1;
	}
}




sub serial_open {
	my ($serial_port, $baud_rate) = @_;
	

	# Create Serial Port and check for features
	my $serial = new Device::SerialPort( $serial_port )
	or die "Failed to create SerialPort object: $!";
	die "ioctl isn't available for serial port: $serial"
	unless ($serial-&gt;can_ioctl());
	die "status isn't available for serial port: $serial"
	unless ($serial-&gt;can_status());
	die "write_done isn't available for serial port: $serial"
	unless ($serial-&gt;can_write_done());
	die "hardware flow control isn't available for serial port: $serial"
	unless ($serial-&gt;can_rtscts());
	
	
	# Configure the Serial Port
	$serial-&gt;baudrate($baud_rate) || die ("Failed to set baud rate");
	$serial-&gt;parity("none") || die ("Failed to set parity");
	$serial-&gt;databits(8) || die ("Failed to set data bits");
	$serial-&gt;stopbits(1) || die ("Failed to set stop bits");
	$serial-&gt;handshake("rts") || die ("Failed to set hardware handshaking");
	$serial-&gt;write_settings || die ("No Settings");


	return $serial;
}


sub serial_write {
	my ($serial, $string) = @_;
	my $bytes = 0;

	# if it doesn't end with a '\r' then append one
	$string .= "\r" if ($string !~ /\r\n?$/);
	
	
	eval {
		local $SIG{ALRM} = sub { die "Timed out."; };
		alarm($Serial_Timeout);
		
		# Send it
		$bytes = $serial-&gt;write( $string );
		
		# Block until it is sent
		while(($serial-&gt;write_done(0))[0] == 0) {}
		
		alarm 0;
	};
	
	if ($@) {
		die unless $@ eq "Timed out.\n";   # propagate unexpected errors
		# timed out
		warn "Timed out while writing to serial port.\n";
 	}	


	# Debugging: display what was read in
	if ($Debug) {
		$string=~s/([^\040-\176])/sprintf("{0x%02X}",ord($1))/ge;
		print "written -&gt;$string&lt;- ($bytes)\n";
	}
}


sub serial_read
{
	my $serial = shift;
	my ($string, $bytes) = ('', 0);

	eval {
		local $SIG{ALRM} = sub { die "Timed out."; };
		alarm($Serial_Timeout);
		
		while (1) {
			my ($count,$got)=$serial-&gt;read(255);
			$string.=$got;
			$bytes+=$count;
			last if ($string =~ /\r\n?$/);
		}
		
		alarm 0;
	};
	
	if ($@) {
		die unless $@ eq "Timed out.\n";   # propagate unexpected errors
		# timed out
		warn "Timed out while reading from serial port.\n";
 	}	

	# Debugging: display what was read in
	if ($Debug) {
		my $debug_str = $string;
		$debug_str=~s/([^\040-\176])/sprintf("{0x%02X}",ord($1))/ge;
		print "saw -&gt;$debug_str&lt;- ($bytes)\n";
	}
	
	return $string;
}


sub serial_close
{
	my $serial = shift;
	
	$serial-&gt;close || warn "Failed to close serial port.";
	undef $serial;
}


__END__


=head1 NAME

ino711d - Web/HTTP based admin interface for the Inovonics 711 RDS/RBDS Generator

=head1 VERSION

This document describes version 0.2 of ino711d, released 19th March 2004.

=head1 DESCRIPTION

ino711d is a completely self-contained perl script, with built-in web server, making it very easy to configure and deploy.

My primary reason for writing this software was so that I could update the PTY (Program Type) and RadioText automatically remotely. All the parameters can be modified very easily using the GET method on a URL: http://127.0.0.1:8080/set?TEXT=Hello+World.

=head1 README

This script is a Web/HTTP based admin interface for the Inovonics 711 RDS/RBDS Generator.

=head1 PREREQUISITES

This script requires the modules from the C&lt;libwww-perl&gt; package.  It also requires the following other modules from CPAN: C&lt;HTML-Parser&gt;, C&lt;URI&gt;, C&lt;Device-SerialPort&gt;, C&lt;Time-HiRes&gt;, C&lt;XML-Simple&gt;.


=pod OSNAMES

Linux

=pod SCRIPT CATEGORIES

Web
Misc

=head1 AUTHOR

Nicholas Humfrey E&lt;lt&gt;njh@ecs.soton.ac.ukE&lt;gt&gt;

=head1 COPYRIGHT

    Copyright (c) 2004, University of Southampton. All Rights Reserved.
    This module is free software. It may be used, redistributed
        and/or modified under the same terms as Perl itself.

=cut

</pre></body></html>