537 lines
12 KiB
Perl
537 lines
12 KiB
Perl
package Net::Symon::NetBrite;
|
|
|
|
our $VERSION = '0.01';
|
|
|
|
=head1 NAME
|
|
|
|
Net::Symon::NetBrite - Talk to Symon NetBrite LED signs
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Net::Symon::NetBrite qw(:constants);
|
|
use Net::Symon::NetBrite::Zone;
|
|
|
|
my $sign = new Net::Symon::NetBrite(
|
|
address => '192.168.34.56',
|
|
);
|
|
|
|
my $zone = new Net::Symon::NetBrite::Zone(
|
|
rect => [0, 0, 200, 24],
|
|
default_font => 'monospace_16',
|
|
);
|
|
|
|
$sign->zones(
|
|
myzone => $zone,
|
|
);
|
|
|
|
$sign->message('myzone', '{green}west philadelphia {red}born and raised');
|
|
|
|
$sign->reboot();
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Do you have a bunch of Symon NetBrite II signs laying around from a
|
|
company you acquired that had more money than sense? So do we!
|
|
|
|
=cut
|
|
|
|
use IO::Socket::INET;
|
|
use Digest::CRC;
|
|
use Carp;
|
|
require Exporter;
|
|
|
|
use constant {
|
|
COLOR_RED => 0x01,
|
|
COLOR_GREEN => 0x02,
|
|
COLOR_YELLOW => 0x03,
|
|
|
|
SCROLL_SLOW => 0x01,
|
|
SCROLL_MED => 0x02,
|
|
SCROLL_FAST => 0x03,
|
|
|
|
PRI_OVERRIDE => 0x01,
|
|
PRI_INTERRUPT => 0x02,
|
|
PRI_FOLLOW => 0x03,
|
|
PRI_YIELD => 0x04,
|
|
PRI_ROUNDROBIN => 0x0a,
|
|
};
|
|
|
|
our %fonts = (
|
|
monospace_16 => 0x00,
|
|
proportional_7 => 0x01,
|
|
proportional_5 => 0x02,
|
|
proportional_11 => 0x03,
|
|
monospace_24 => 0x04,
|
|
bold_proportional_7 => 0x05,
|
|
bold_proportional_11 => 0x06,
|
|
monospace_7 => 0x07,
|
|
script_16 => 0x08,
|
|
proportional_9 => 0x09,
|
|
picture_24 => 0x0a,
|
|
);
|
|
|
|
our @ISA = qw(Exporter);
|
|
my @consts = qw( COLOR_RED COLOR_GREEN COLOR_YELLOW
|
|
SCROLL_SLOW SCROLL_MED SCROLL_FAST
|
|
PRI_OVERRIDE PRI_INTERRUPT PRI_FOLLOW PRI_YIELD PRI_ROUNDROBIN);
|
|
our @EXPORT_OK = @consts;
|
|
our %EXPORT_TAGS = ( constants => \@consts );
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 new()
|
|
|
|
Creates a new instance, which handles a single sign. The following
|
|
parameters are accepted:
|
|
|
|
=over
|
|
|
|
=item address
|
|
|
|
The address of the sign.
|
|
|
|
=item port
|
|
|
|
(optional) The destination port. Defaults to 700.
|
|
|
|
=item callback
|
|
|
|
If supplied, no socket will be created. Instead, the supplied coderef
|
|
will be called with a single argument whenever data needs to be sent.
|
|
This is intended for use with an external framework like L<POE|POE>.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my ($class, %data) = @_;
|
|
my $self = {};
|
|
|
|
if ($data{callback}) {
|
|
$self->{callback} = $data{callback};
|
|
} elsif ($data{address}) {
|
|
$self->{addr} = $data{address};
|
|
$self->{port} = $data{port} || 700;
|
|
} else {
|
|
croak 'Either address or callback must be supplied';
|
|
}
|
|
|
|
$self->{seqno} = 0;
|
|
$self->{sessno} = 0;
|
|
|
|
bless($self, $class);
|
|
return $self;
|
|
}
|
|
|
|
sub pkt_escape {
|
|
my $pkt = shift;
|
|
my $esc = pack('C', 0x10);
|
|
my $buf;
|
|
|
|
for (my $i = 0; $i < length $pkt; $i++) {
|
|
my $byte = unpack("x[$i]C", $pkt);
|
|
|
|
if ($i > 4 && $i < length($pkt) - 4 && ($byte == 0x10 || $byte == 0x01 || $byte == 0x04 || $byte == 0x17)) {
|
|
$buf .= $esc;
|
|
}
|
|
|
|
$buf .= pack('C', $byte);
|
|
}
|
|
|
|
return $buf;
|
|
}
|
|
|
|
sub crc { return Digest::CRC::crc(shift, 16, 0x0000, 0x0000, 1, 0x1021, 1, 0) }
|
|
|
|
sub tx {
|
|
my ($self, $pkt) = @_;
|
|
|
|
if (defined $self->{callback}) {
|
|
$self->{callback}->($pkt);
|
|
} else {
|
|
$self->{sock}->send($pkt);
|
|
$self->{sock}->flush();
|
|
}
|
|
}
|
|
|
|
sub connect {
|
|
my $self = shift;
|
|
|
|
$self->{sock} = IO::Socket::INET->new(
|
|
PeerAddr => $self->{addr},
|
|
PeerPort => 700,
|
|
Proto => 'tcp',
|
|
);
|
|
|
|
unless (defined $self->{sock}) {
|
|
croak "Socket: $!";
|
|
}
|
|
|
|
$self->{sessno} = 0;
|
|
#$self->zones();
|
|
}
|
|
|
|
=head2 zones()
|
|
|
|
Updates the list of zones associated with the sign. Any existing
|
|
zones are replaced. The zones will be sent to the sign immediately
|
|
and upon every successful reconnection.
|
|
|
|
The only parameter is a hash, in which the keys are zone names and the
|
|
values are L<Net::Symon::NetBrite::Zone|Net::Symon::NetBrite::Zone>
|
|
objects.
|
|
|
|
If called without a list of zones, the last provided zones will be
|
|
sent to the sign again.
|
|
|
|
=cut
|
|
|
|
sub zones {
|
|
my ($self, %zones) = @_;
|
|
|
|
if (%zones) {
|
|
$self->{zones} = \%zones;
|
|
} elsif (!defined $self->{zones}) {
|
|
return undef;
|
|
}
|
|
|
|
if (!defined $self->{sock}) {
|
|
$self->connect();
|
|
}
|
|
|
|
|
|
my $zid = 1;
|
|
foreach my $zname (sort { $a cmp $b } keys %{$self->{zones}}) {
|
|
my $z = $self->{zones}->{$zname};
|
|
$z->id($zid);
|
|
|
|
my $ztext = &parse_msg($z->get('initial_text'));
|
|
my $zlen = length $ztext;
|
|
|
|
my $body = pack("C4 CC4 C3 Cv C8 C C4 C4 vC5 C10 C3 C20vC3C11A[$zlen] C",
|
|
0x0f, 0x00, 0x0e, 0x02, # body start
|
|
$zid, @{$z->get('rect')}, # zone def
|
|
0x0d, $z->get('scroll_speed'), 0x00, # scroll rate
|
|
0x0c, $z->get('pause_duration'), # pause duration
|
|
0x0b, 0xfe, 0x0a, 0xe8, 0x03, 0x09, 0x0e, 0x08, # msg def params
|
|
$z->get('volume'), # volume (0-8)
|
|
0x07, $fonts{$z->get('default_font')}, 0x06, $z->get('default_color'), # default font
|
|
0x05, 0x00, 0x00, 0x04, # font footer
|
|
2012, 2, 10, 19, 21, 33, # timestamp: yyyy, mo, d, h, min, sec?
|
|
# tfmt
|
|
0x00, 0x03, 0x00, 0x00, 0x2f, 0x02, 0xff, 0x10, 0x3a, 0x01, # def message hdr
|
|
$zid, 0x00, 0x03,
|
|
# it's magic, i ain't gotta explain shit
|
|
#0x0e, 0x00,
|
|
0x02, 0x00, 0x00, 0x00,
|
|
0x00, 0x00, 0x03, 0x00,
|
|
0x00, 0x00, 0x00, 0x00,
|
|
0x00, 0x00, 0x00, 0xfe,
|
|
0x7e, 0x00, 0x02, 0x00,
|
|
$zlen, 0x00, 0x00, 0x04,
|
|
0x00, 0x00, 0x00, 0x00,
|
|
0x00, 0x00, 0x00, 0x00,
|
|
0xfe, 0x7e, 0x00, $ztext,
|
|
0x17, # body end
|
|
);
|
|
|
|
my $header = pack('C3 v v C3 C2 C4 C2 C2',
|
|
0x16, 0x16, 0x01, # msg start
|
|
length($body),
|
|
++$self->{seqno},
|
|
0x00, 0x01, 0x00,
|
|
0x01, 0x01, # type = init
|
|
0x00, 0xc8, 0x01, 0x00, # sign id
|
|
0x00, ++$self->{sessno}, # session packet count
|
|
0x04, 0x00, # header end
|
|
);
|
|
|
|
my $footer = pack('vC',
|
|
crc($header.$body),
|
|
0x04, # msg end
|
|
);
|
|
|
|
$self->tx(&pkt_escape($header.$body.$footer));
|
|
|
|
print "sent zone $zid with seqno ", $self->{seqno}, " sessno ", $self->{sessno}, "\n";
|
|
|
|
$zid++;
|
|
}
|
|
}
|
|
|
|
=head2 message()
|
|
|
|
Sends a message to a zone. Accepts the zone name, message text and an
|
|
optional hashref containing any of the following parameters:
|
|
|
|
=over
|
|
|
|
=item priority
|
|
|
|
The message priority determines how the new message will replace an
|
|
existing one. The default is C<PRI_FOLLOW>, but can also be
|
|
C<PRI_OVERRIDE>, C<PRI_INTERRUPT>, C<PRI_YIELD> or C<PRI_ROUNDROBIN>.
|
|
|
|
=item activation_delay
|
|
|
|
Message activation delay in milliseconds. Default is 0.
|
|
|
|
=item display_deplay
|
|
|
|
Message display delay in milliseconds. Default is 0.
|
|
|
|
=item display_repeat
|
|
|
|
Not really sure. The default is 0.
|
|
|
|
=item ttl
|
|
|
|
The message will self-destruct in C<ttl> seconds. Default is 0.
|
|
|
|
=item sound_alarm
|
|
|
|
If true, the sign will beep when the message is displayed.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub message {
|
|
my ($self, $zname, $text, $param) = @_;
|
|
my $z = $self->{zones}->{$zname};
|
|
|
|
unless ($z) {
|
|
return undef;
|
|
}
|
|
|
|
print "sending to zone $zname with id ", $z->id, "\n";
|
|
|
|
my $ztext = &parse_msg($text);
|
|
my $zlen = length $ztext;
|
|
|
|
# uck
|
|
if ($zlen == 4 || $zlen == 5) {
|
|
$ztext = pack('C2', 0x10, 0x15).$ztext;
|
|
$zlen += 2;
|
|
}
|
|
|
|
my $body = pack("V C v v v v C C2 A[$zlen] C",
|
|
$zlen,
|
|
$param->{priority} || PRI_OVERRIDE,
|
|
$param->{activation_delay} || 0,
|
|
$param->{display_delay} || 0,
|
|
$param->{display_repeat} || 0,
|
|
$param->{ttl} || 0,
|
|
($param->{sound_alarm} ? 0xff : 0xfe),
|
|
0x00, 0x00, # msg slot
|
|
$ztext,
|
|
0x17, # body end
|
|
);
|
|
|
|
my $maskbytes = $z->id / 8;
|
|
if (int($maskbytes) != $maskbytes) { $maskbytes = int($maskbytes) + 1 }
|
|
my $zmask = pack($z->id > 0xff ? 'v' : 'C', 1 << ($z->id - 1));
|
|
my $zmlen = length $zmask;
|
|
|
|
printf("zmask: %s bytes: %d\n", unpack('H*', $zmask), $maskbytes);
|
|
|
|
my $header = pack("C3 v v C3 C2 Ca[$zmlen] C2",
|
|
0x16, 0x16, 0x01, # msg start
|
|
length($body) + 1,
|
|
++$self->{seqno},
|
|
0x00, 0x01, 0x00,
|
|
0x03, $maskbytes * 8,
|
|
0x00, $zmask,
|
|
0x02, 0x00, # header end
|
|
);
|
|
|
|
my $footer = pack('vC',
|
|
crc($header.$body),
|
|
0x04, # msg end
|
|
);
|
|
|
|
$self->tx(&pkt_escape($header.$body.$footer));
|
|
}
|
|
|
|
=head2 reboot()
|
|
|
|
Instructs the sign to reboot.
|
|
|
|
=cut
|
|
|
|
sub reboot {
|
|
my $self = shift;
|
|
|
|
my $pkt = pack('C3vvC4C*',
|
|
0x16, 0x16, 0x01, # msg start
|
|
2, # body length
|
|
++$self->{seqno}, # packet count
|
|
0x00, 0x01, 0x00,
|
|
0x01, 0x01, # msg type: reset
|
|
0x00, 0xc8, 0x01, 0x00, # sign id
|
|
0x00, 0x01, 0x0f, 0x00, # reset msg
|
|
0x17, # crc follows
|
|
);
|
|
|
|
$pkt .= pack('vC',
|
|
crc($pkt),
|
|
0x04, # msg end
|
|
);
|
|
|
|
$self->tx(&pkt_escape($pkt));
|
|
}
|
|
|
|
=head1 Message Formatting
|
|
|
|
The NetBrite signs have a few formatting switches that can be applied
|
|
in-line to messages. This is implemented as a kind of markup.
|
|
|
|
=over
|
|
|
|
=item C<{scrolloff}>, C<{scrollon}>
|
|
|
|
Turns scrolling on or off. This works in the middle of a message, but
|
|
seems to have a tendency to mess things up.
|
|
|
|
=item C<{blinkon}>, C<{blinkoff}>
|
|
|
|
Turns blinking on or off.
|
|
|
|
=item C<{red}>, C<{green}>, C<{yellow}>
|
|
|
|
Changes the text color.
|
|
|
|
=item C<{left}>, C<{center}>, C<{right}>
|
|
|
|
Changes the text's alignment within its zone.
|
|
|
|
=item C<{pause}>
|
|
|
|
Briefly pauses the display, probably for the amount of time specified
|
|
in the zone definition.
|
|
|
|
=item C<{erase}>
|
|
|
|
Erases.
|
|
|
|
=item C<{serial}>
|
|
|
|
Inserts the sign's serial number, which seems to always be its
|
|
Ethernet MAC address.
|
|
|
|
=item C<{bell}>
|
|
|
|
Beeps.
|
|
|
|
=item C<{note [pitch] [duration]}>
|
|
|
|
Beeps at C<pitch> for C<duration>. The pitch is a positive integer, possibly
|
|
0-254 and the duration is in milliseconds.
|
|
|
|
=item C<{tune [1-9] ["repeat"]}>
|
|
|
|
Plays one of nine predefined tunes. #9 is Charge!
|
|
|
|
If I<repeat> is specified, the tune will play every time the message is
|
|
displayed. This is extremely annoying.
|
|
|
|
=item C<{font [font_name]}>
|
|
|
|
Switches to C<font_name>. See L</Available Fonts>.
|
|
|
|
Note that the sign won't change to a font that's taller than its
|
|
containing zone.
|
|
|
|
=back
|
|
|
|
=head1 Available Fonts
|
|
|
|
The following fonts are available:
|
|
|
|
=over
|
|
|
|
=item monospace_7
|
|
|
|
=item monospace_16
|
|
|
|
=item monospace_24
|
|
|
|
=item proportional_7
|
|
|
|
=item proportional_5
|
|
|
|
=item proportional_9
|
|
|
|
=item proportional_11
|
|
|
|
=item bold_proportional_7
|
|
|
|
=item bold_proportional_11
|
|
|
|
=item script_16
|
|
|
|
=item picture_24
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub parse_msg {
|
|
my $msg = shift;
|
|
|
|
$msg =~ s!\{scrolloff\}!pack('C*', 0x10, 0x14)!ieg;
|
|
$msg =~ s!\{scrollon\}!pack('C*', 0x10, 0x15)!ieg;
|
|
|
|
$msg =~ s!\{blinkoff\}!pack('C*', 0x10, 0x01)!ieg;
|
|
$msg =~ s!\{blinkon\}!pack('C*', 0x10, 0x00)!ieg;
|
|
|
|
$msg =~ s!\{red\}!pack('C*', 0x10, 0x0c, COLOR_RED)!ieg;
|
|
$msg =~ s!\{green\}!pack('C*', 0x10, 0x0c, COLOR_GREEN)!ieg;
|
|
$msg =~ s!\{yellow\}!pack('C*', 0x10, 0x0c, COLOR_YELLOW)!ieg;
|
|
|
|
$msg =~ s!\{left\}!pack('C*', 0x10, 0x27)!ieg;
|
|
$msg =~ s!\{center\}!pack('C*', 0x10, 0x29)!ieg;
|
|
$msg =~ s!\{right\}!pack('C*', 0x10, 0x28)!ieg;
|
|
|
|
$msg =~ s!\{pause\}!pack('C*', 0x10, 0x05)!ieg;
|
|
$msg =~ s!\{erase\}!pack('C*', 0x10, 0x03)!ieg;
|
|
$msg =~ s!\{serial\}!pack('C*', 0x10, 0x09)!ieg;
|
|
$msg =~ s!\{bell\}!pack('C*', 0x10, 0x05)!ieg;
|
|
$msg =~ s!\{note\s+(\d+)\s+(\d+)\}!pack('C2Cv', 0x10, 0x11, $1, $2)!ieg;
|
|
$msg =~ s!\{tune\s+([1-9])(\s+repeat)?\}!pack('C2C', 0x10, ($2 ? 0x0a : 0x0b), $1)!ieg;
|
|
$msg =~ s!\{font\s+(\S+)\}!pack('C2C', 0x10, 0x0d, $fonts{$1})!ieg;
|
|
|
|
return $msg;
|
|
}
|
|
|
|
=head1 BUGS
|
|
|
|
There is no error checking of any kind.
|
|
|
|
Handling of sequence numbers should probably be better.
|
|
|
|
We don't bother to set the time on the sign, or do any of the
|
|
time/date formatting stuff. Sorry, I don't use it; send patches.
|
|
|
|
No support for message slots.
|
|
|
|
Socket handling stuff is embarrassing.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Ben Wilber <ben@desync.com>
|
|
|
|
Most of the credit goes to the author of
|
|
L<NetPenguin Server|http://www.thepenguinmaster.com/>, who did the
|
|
hard work of figuring out the protocol. Consider supporting that
|
|
project if you find this useful.
|
|
|
|
=head1 LICENSE
|
|
|
|
This library is free software and may be distributed under the same
|
|
terms as Perl itself.
|
|
|
|
=cut
|
|
|
|
1;
|