ProLite - Perl extension to control Pro-Lite LED Message Signs

  use ProLite qw(:core);

  my $s = new ProLite(id=>1, device=>'/dev/ttyS0', debug=>0, charDelay=>2000);

  $err = $s->connect();
  die "Can't connect to device - $err" if $err;

  $s->wakeUp();
  $s->setPage(1, "Hello World");
  $s->runPage(1);

  :core      methods responsible for basic communication
  :commands  methods responsible for the control of sign functions
  :colors    constants for text colors (see below)
  :styles    constants for text styles
  :dingbats  constants for graphic characters
  :effects   constants for transition effects

  my $s = new ProLite(id=>1, device=>'/dev/ttyS0', debug=>0, charDelay=>2000);

  $err = $s->connect();
  die "Can't connect to device - $err" if $err;

  $s->wakeUp();

  RESET             dimRed              red                 brightRed
  orange            brightOrange        dimYellow           yellow 
  brightYellow      dimLime             lime                brightLime
  brightGreen       green               dimGreen

  yellowSRedOnGreen rainbow             redSGreen           redSYellow
  greenSRed         greenSYellow        greenOnRed          redOnGreen
  orangeSBlackOnGr  limeSBlackOnRed     greenSBlackOnRed    redSBlackOnGreen 

  blank             normal              bold                italic
  boldItalic        normalFlash         boldFlash           italicFlash
  boldItalicFlash

  uncondensed       condensed 

  telephone         glasses             faucet              rocket
  monster           key                 shirt               helicopter
  car               tank                house               teaPot
  knifeFork         duck                motorcycle          bicycle
  crown             twinHearts          arrowR              arrowL
  arrowDL           arrowUL             beerGlass           chair
  shoe              wineGlass 

  autoL             openOutL            coverOutL           cyclingL
  closeRT           closeLT             closeInT            scrollUpL
  scrollDownL       overlapL            stackingL           comic1L
  comic2L           appearL             randomL             shiftLeftL
  magicL

  thankyou          welcome

  currentTime       target              current             dayLeft
  hourLeft          minLeft             secLeft

  beep              pauseT

  date

package ProLite;

require 5.005_62;
use strict;
use warnings;

require Exporter;
use AutoLoader qw(AUTOLOAD);

use Time::HiRes qw(usleep);
use Device::SerialPort 0.05;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
	'all' => [ qw(
		dimRed red brightRed orange brightOrange dimYellow yellow 
		brightYellow dimLime lime brightLime brightGreen green dimGreen
		
		yellowSRedOnGreen rainbow redSGreen redSYellow greenSRed greenSYellow 
		greenOnRed redOnGreen orangeSBlackOnGreen limeSBlackOnRed greenSBlackOnRed 
		redSBlackOnGreen 

		RESET blank normal bold italic boldItalic 
		normalFlash boldFlash italicFlash boldItalicFlash uncondensed condensed 

		telephone glasses faucet rocket monster key shirt 
		helicopter car tank house teaPot knifeFork duck motorcycle bicycle crown 
		twinHearts arrowR arrowL arrowDL arrowUL beerGlass chair shoe wineGlass 

		autoL openOutL coverOutL date cyclingL closeRT closeLT closeInT scrollUpL
		scrollDownL overlapL stackingL comic1L comic2L beep pauseT appearL randomL
		shiftLeftL currentTime magicL thankyou welcome linkPage target current
		dayLeft hourLeft minLeft secLeft
		
		new connect waiting getBytes sendCommand pretty plIndex
		
		wakeUp deletePage deleteGraphic deleteAll setPage runPage signInfo
		factoryReset setSpeed setClock pad targetUp targetDown chain
	)],
	
	'core' => [ qw(
		new connect waiting getBytes sendCommand pretty plIndex
	)],
	
	'commands' => [ qw(
		wakeUp deletePage deleteGraphic deleteAll setPage runPage signInfo
		factoryReset setSpeed setClock pad targetUp targetDown chain
	)],
	
	'colors' => [ qw(
		RESET dimRed red brightRed orange brightOrange dimYellow yellow 
		brightYellow dimLime lime brightLime brightGreen green dimGreen
		
		yellowSRedOnGreen rainbow redSGreen redSYellow greenSRed greenSYellow 
		greenOnRed redOnGreen orangeSBlackOnGreen limeSBlackOnRed greenSBlackOnRed 
		redSBlackOnGreen 
	)],
	
	'styles' => [ qw(
		RESET blank normal bold italic boldItalic 
		normalFlash boldFlash italicFlash boldItalicFlash uncondensed condensed 
	)],
	
	'dingbats' => [ qw(
		RESET telephone glasses faucet rocket monster key shirt 
		helicopter car tank house teaPot knifeFork duck motorcycle bicycle crown 
		twinHearts arrowR arrowL arrowDL arrowUL beerGlass chair shoe wineGlass 
	)],

	'effects' => [ qw(
		autoL openOutL coverOutL date cyclingL closeRT closeLT closeInT scrollUpL
		scrollDownL overlapL stackingL comic1L comic2L beep pauseT appearL randomL
		shiftLeftL currentTime magicL thankyou welcome linkPage target current
		dayLeft hourLeft minLeft secLeft
	)],
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = ( qw(
		new connect waiting getBytes sendCommand pretty plIndex
		
		wakeUp deletePage deleteGraphic deleteAll setPage runPage signInfo
		factoryReset setSpeed setClock pad targetUp targetDown chain
));

our $VERSION = '0.01';

1;

__END__

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

sub dimRed 					{return  '<CA>'}
sub red 					{return  '<CB>'}
sub brightRed 				{return  '<CC>'}
sub orange 					{return  '<CD>'}
sub brightOrange 			{return  '<CE>'}
sub dimYellow 				{return  '<CF>'}
sub yellow 					{return  '<CG>'}
sub brightYellow 			{return  '<CH>'}
sub dimLime 				{return  '<CI>'}
sub lime 					{return  '<CJ>'}
sub brightLime 				{return  '<CK>'}
sub brightGreen 			{return  '<CL>'}
sub green 					{return  '<CM>'}
sub dimGreen 				{return  '<CN>'}

sub yellowSRedOnGreen 		{return  '<CO>'}
sub rainbow 				{return  '<CP>'}
sub redSGreen 				{return  '<CQ>'}
sub redSYellow 				{return  '<CR>'}
sub greenSRed 				{return  '<CS>'}
sub greenSYellow 			{return  '<CT>'}
sub greenOnRed 				{return  '<CU>'}
sub redOnGreen 				{return  '<CV>'}
sub orangeSBlackOnGreen 	{return  '<CW>'}
sub limeSBlackOnRed 		{return  '<CX>'}
sub greenSBlackOnRed 		{return  '<CY>'}
sub redSBlackOnGreen 		{return  '<CZ>'}

sub RESET 					{return  '<SA><SI><CP>'}
sub blank 					{return  '                '}

sub normal 					{return  '<SA>'}
sub bold 					{return  '<SB>'}
sub italic 					{return  '<SC>'}
sub boldItalic				{return  '<SD>'}
sub normalFlash 			{return  '<SE>'}
sub boldFlash 				{return  '<SF>'}
sub italicFlash 			{return  '<SG>'}
sub boldItFlash 			{return  '<SH>'}
sub uncondensed 			{return  '<SI>'}
sub condensed 				{return  '<SJ>'}

sub telephone 				{return  '<BA>'}
sub glasses 				{return  '<BB>'}
sub faucet 					{return  '<BC>'}
sub rocket 					{return  '<BD>'}
sub monster 				{return  '<BE>'}
sub key 					{return  '<BF>'}
sub shirt 					{return  '<BG>'}
sub helicopter 				{return  '<BH>'}
sub car 					{return  '<BI>'}
sub tank 					{return  '<BJ>'}
sub house 					{return  '<BK>'}
sub teaPot 					{return  '<BL>'}
sub knifeFork 				{return  '<BM>'}
sub duck 					{return  '<BN>'}
sub motorcycle 				{return  '<BO>'}
sub bicycle 				{return  '<BP>'}
sub crown 					{return  '<BQ>'}
sub twinHearts 				{return  '<BR>'}
sub arrowR 					{return  '<BS>'}
sub arrowL 					{return  '<BT>'}
sub arrowDL 				{return  '<BU>'}
sub arrowUL 				{return  '<BV>'}
sub beerGlass 				{return  '<BW>'}
sub chair 					{return  '<BX>'}
sub shoe 					{return  '<BY>'}
sub wineGlass 				{return  '<BZ>'}

sub autoL 					{return  '<FA>'}
sub openOutL 				{return  '<FB>'}
sub coverOutL 				{return  '<FC>'}
sub date 					{return  '<FD>'}
sub cyclingL 				{return  '<FE>'}
sub closeRT 				{return  '<FF>'}
sub closeLT 				{return  '<FG>'}
sub closeInT 				{return  '<FH>'}
sub scrollUpL 				{return  '<FI>'}
sub scrollDownL 			{return  '<FJ>'}
sub overlapL 				{return  '<FK>'}
sub stackingL 				{return  '<FL>'}
sub comic1L 				{return  '<FM>'}
sub comic2L 				{return  '<FN>'}
sub beep 					{return  '<FO>'}
sub pauseT 					{return  '<FP>'}
sub appearL 				{return  '<FQ>'}
sub randomL 				{return  '<FR>'}
sub shiftLeftL 				{return  '<FS>'}
sub currentTime 			{return  '<FT>'}
sub magicL 					{return  '<FU>'}
sub thankyou 				{return  '<FV>'}
sub welcome 				{return  '<FW>'}
sub linkPage 				{return  '<FZ>'}
sub target 					{return  '<F1>'}
sub current 				{return  '<F2>'}
sub dayLeft 				{return  '<F3>'}
sub hourLeft 				{return  '<F4>'}
sub minLeft 				{return  '<F5>'}
sub secLeft 				{return  '<F6>'}

sub new
{
	my $that  = shift;
	my $class = ref($that) || $that;
			   
	my(%params) = @_;

	my $this = {};

	bless $this, $class;
	
	$this->{device} = $params{'device'};
	$this->{debug} = $params{'debug'};
	$this->{id} = $params{'id'};
	$this->{maxReadAttempts} = $params{'maxReadAttempts'} || 10000;
	
	return $this;
}



sub connect
{
	my($this) = @_;
	
	my $ob = Device::SerialPort->new ($this->{device}, 'quiet') || return "".$this->{device}.": $!";

	$ob->baudrate(9600)     || die "fail setting baudrate";
	$ob->parity("none")     || die "fail setting parity";
	$ob->databits(8)        || die "fail setting databits";
	$ob->stopbits(1)        || die "fail setting stopbits";
	$ob->handshake("none")  || die "fail setting handshake";
	$ob->write_settings || die "no settings";
	
	$ob->purge_all();

	$this->{connection} = $ob;	
	
	print STDERR "Connected\n" if $this->{debug};
	
	return 0;
}



sub waiting
{
	my($this) = @_;
	
	my($ob) = $this->{connection};

	($num, $data) = $ob->read(1);	# Read a byte;
	
	$this->{pending} = $data if ($num>0);
	
	return $num;
}



sub getBytes
{
	my($this) = @_;
	my($dataRead, $readCount);
	undef $done;
	
	my($ob) = $this->{connection};

	$dataRead .= $this->{pending};
	my $mra = $this->{'maxReadAttempts'};
	
	print "<-" if $this->{'debug'};
	while(not $done)
	{
		do
		{
			$readCount ++;
			($num, $data) = $ob->read(100);	# Read a byte;
			print pretty($data) if $data and $this->{'debug'}; 
		}until ($num>0 or $readCount > $mra);

		$dataRead .= $data;
		$done = 1 if $dataRead =~ /\r|\n/;
		$done = 2 if $readCount > $mra;
	}
	print "\n" if $this->{'debug'};

	return $done == 2 ? $readCount : $dataRead;
}



sub sendCommand
{
	my($this, $data, $global) = @_;
	my($gotOK) = 0;
	my($count, $response);

	my($ob) = $this->{connection};
	$ob->purge_all();

	# Make the ID
	$id = $this->{id};
	$id = "0$id" if $id < 10;
	$id = "<ID$id>";
	$id = '' if $global;
	
	do
	{
		$count ++;
		
		# Send the command
		print "->" if $this->{'debug'};
		foreach $ch (split '', "$id$data\r\n")
		{
			$ob->write($ch);
			usleep(5000);
			print pretty($ch) if $this->{'debug'};
		}
		print " [$count]\n" if $this->{'debug'};

		# Get the response
		unless($global)
		{
			$response = $this->getBytes();
			$response =~ s/$id//;
			$response =~ s/[\r\n]+//g;
			chomp $response;
		}
	} until ($response eq 'S' || $global);
	return $response;
}



sub pretty
{
	my($str) = @_;

	$str =~ s/\r/<CR>/g;
	$str =~ s/\n/<NL>/g;
	$str =~ s/\e/<ESC>/g;
	$str =~ s/\001/<1>/g;
	$str =~ s/\002/<2>/g;
	$str =~ s/\003/<3>/g;
	$str =~ s/\034/<FS>/g;
	$str =~ s/[\001-\037]/<*>/g;

	$str;
}



sub plIndex
{
	my($index) = @_;
	
	return '*' if $index eq 'ALL';
	return chr($index + 64);
}

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

sub wakeUp
{
	my($this) = @_;
	
	return $this->sendCommand();
}


sub deletePage
{
	my($this, $page) = @_;
	
	$page = plIndex($page);
	
	$this->sendCommand("<DP$page>");
}


sub deleteGraphic
{
	my($this, $page) = @_;
	
	$page = plIndex($page);
	
	$this->sendCommand("<DG$page>");
}


sub deleteAll
{
	my($this) = @_;
	
	$this->sendCommand("<D*>");
}


sub setPage
{
	my($this, $page, @content) = @_;
	
	$page = plIndex($page);
	my $content = join '', @content;
	
	$this->sendCommand("<P$page>$content");
}


sub runPage
{
	my($this, $page) = @_;
	
	$page = plIndex($page);
	
	$this->sendCommand("<RP$page>");
}


sub signInfo
{
	my($this) = @_;
	
	$this->sendCommand("<?>");
}


sub factoryReset
{
	my($this) = @_;

	$this->sendCommand("<RST>");
}


sub setSpeed
{
	my($this, $speed) = @_;
	
	$speed = plIndex($speed);
	
	$this->sendCommand("<SPD$speed>");
}


sub setClock
{
	my($this) = @_;
	
	my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
	$year += 1900;
	$mon ++;
	
	$mon = pad($mon, 2);
	$mday = pad($mday, 2);
	$hour = pad($hour, 2);
	$min = pad($min, 2);
	$sec = pad($sec, 2);
# <TCCYYMMDDWhhmmssH>

	$this->sendCommand("<T$year$mon$mday$wday$hour".$min.$sec."0>", 1);
}

sub pad
{
	my($val, $places) = @_;
	
	return '0' x ($places - length $val). $val;
}
	


sub targetUp
{
	my($this, $type, $value, $target, $page) = @_;
	
	$type = $type eq 'DAYS' ? 'D':'H';
	$value = '0' x (4 - length $value) . $value;
	$target = '0' x (4 - length $target) . $target;
	$page = plIndex($page);
	
	$this->sendCommand("<U$type$value$target$page>");
}


sub targetDown
{
	my($this, $days, $hours, $mins, $page) = @_;
	
	$days = '0' x (4 - length $days) . $days;
	$hours = '0' x (2 - length $hours) . $hours;
	$mins = '0' x (2 - length $mins) . $mins;
	$page = plIndex($page);
	
	$this->sendCommand("<V$days$hours$mins$page>");
}



sub chain
{
	my($next) = @_;
	
	return linkPage."<".plIndex($next).">";
}