#!/usr/bin/perl -w

use IO::Socket;
use IO::Select;
use RRDs;
use Data::Dumper;



#config part
$own_net = 0;
$own_sub = 0;
$own_addr = 2;

$dst_net = 3;
$dst_sub = 2;
$dst_addr = 0x7d;

#end of config part

@own = ($own_net, $own_sub, $own_addr);
@dst = ($dst_net, $dst_sub, $dst_addr);

sub crc_ccitt_byte {
my ($crc, $byte) = (shift, shift);
my @crc_ccitt_table = (
	0x0000, 0x1189, 0x2312, 0x329b, 0x4624, 0x57ad, 0x6536, 0x74bf,
	0x8c48, 0x9dc1, 0xaf5a, 0xbed3, 0xca6c, 0xdbe5, 0xe97e, 0xf8f7,
	0x1081, 0x0108, 0x3393, 0x221a, 0x56a5, 0x472c, 0x75b7, 0x643e,
	0x9cc9, 0x8d40, 0xbfdb, 0xae52, 0xdaed, 0xcb64, 0xf9ff, 0xe876,
	0x2102, 0x308b, 0x0210, 0x1399, 0x6726, 0x76af, 0x4434, 0x55bd,
	0xad4a, 0xbcc3, 0x8e58, 0x9fd1, 0xeb6e, 0xfae7, 0xc87c, 0xd9f5,
	0x3183, 0x200a, 0x1291, 0x0318, 0x77a7, 0x662e, 0x54b5, 0x453c,
	0xbdcb, 0xac42, 0x9ed9, 0x8f50, 0xfbef, 0xea66, 0xd8fd, 0xc974,
	0x4204, 0x538d, 0x6116, 0x709f, 0x0420, 0x15a9, 0x2732, 0x36bb,
	0xce4c, 0xdfc5, 0xed5e, 0xfcd7, 0x8868, 0x99e1, 0xab7a, 0xbaf3,
	0x5285, 0x430c, 0x7197, 0x601e, 0x14a1, 0x0528, 0x37b3, 0x263a,
	0xdecd, 0xcf44, 0xfddf, 0xec56, 0x98e9, 0x8960, 0xbbfb, 0xaa72,
	0x6306, 0x728f, 0x4014, 0x519d, 0x2522, 0x34ab, 0x0630, 0x17b9,
	0xef4e, 0xfec7, 0xcc5c, 0xddd5, 0xa96a, 0xb8e3, 0x8a78, 0x9bf1,
	0x7387, 0x620e, 0x5095, 0x411c, 0x35a3, 0x242a, 0x16b1, 0x0738,
	0xffcf, 0xee46, 0xdcdd, 0xcd54, 0xb9eb, 0xa862, 0x9af9, 0x8b70,
	0x8408, 0x9581, 0xa71a, 0xb693, 0xc22c, 0xd3a5, 0xe13e, 0xf0b7,
	0x0840, 0x19c9, 0x2b52, 0x3adb, 0x4e64, 0x5fed, 0x6d76, 0x7cff,
	0x9489, 0x8500, 0xb79b, 0xa612, 0xd2ad, 0xc324, 0xf1bf, 0xe036,
	0x18c1, 0x0948, 0x3bd3, 0x2a5a, 0x5ee5, 0x4f6c, 0x7df7, 0x6c7e,
	0xa50a, 0xb483, 0x8618, 0x9791, 0xe32e, 0xf2a7, 0xc03c, 0xd1b5,
	0x2942, 0x38cb, 0x0a50, 0x1bd9, 0x6f66, 0x7eef, 0x4c74, 0x5dfd,
	0xb58b, 0xa402, 0x9699, 0x8710, 0xf3af, 0xe226, 0xd0bd, 0xc134,
	0x39c3, 0x284a, 0x1ad1, 0x0b58, 0x7fe7, 0x6e6e, 0x5cf5, 0x4d7c,
	0xc60c, 0xd785, 0xe51e, 0xf497, 0x8028, 0x91a1, 0xa33a, 0xb2b3,
	0x4a44, 0x5bcd, 0x6956, 0x78df, 0x0c60, 0x1de9, 0x2f72, 0x3efb,
	0xd68d, 0xc704, 0xf59f, 0xe416, 0x90a9, 0x8120, 0xb3bb, 0xa232,
	0x5ac5, 0x4b4c, 0x79d7, 0x685e, 0x1ce1, 0x0d68, 0x3ff3, 0x2e7a,
	0xe70e, 0xf687, 0xc41c, 0xd595, 0xa12a, 0xb0a3, 0x8238, 0x93b1,
	0x6b46, 0x7acf, 0x4854, 0x59dd, 0x2d62, 0x3ceb, 0x0e70, 0x1ff9,
	0xf78f, 0xe606, 0xd49d, 0xc514, 0xb1ab, 0xa022, 0x92b9, 0x8330,
	0x7bc7, 0x6a4e, 0x58d5, 0x495c, 0x3de3, 0x2c6a, 0x1ef1, 0x0f78
);

return ($crc >> 8) ^ $crc_ccitt_table[($crc ^ $byte) & 0xff] ;
}

sub crc_ccitt {
my ($crc, @bytes) = (shift, @_);

foreach (@bytes) {
	$crc = crc_ccitt_byte($crc, $_ & 0xff);
}
return $crc;
}

sub aeq {
	my(@a) = splice(@_,0,shift);
	my(@b) = splice(@_,0,shift);
	return 0 unless @a == @b; # same len?
	while (@a) {
		return 0 if pop(@a) ne pop(@b);
	}
	return 1;
}

sub hexb {
	return join(" ", map(sprintf("%02x", $_) , @_));
}
sub hexb_ {
	return join("_", map(sprintf("%02x", $_) , @_));
}

sub make_io {
# ComLynx needs 19200,8,N,1 Half-Duplex no Echo as RS485 settings.
# for direct connection, try IO::File
my ($host, $port, $proto) = ("iolan1", 10001, "tcp");

$s = IO::Socket::INET->new(
	PeerAddr => $host,
	PeerPort => $port,
	Proto => $proto
)
|| die "can't open socket";
$s->autoflush(1); #closest to unbuffered IO in perl

return $s;
}

sub rw {
my ($s, @m) = (shift, @_);
my ($m, $r, @r, $p, $mt ,$rt, $bytes, @srcm, @dstr, $sel);

@srcm = @m[0,1];
$mt = $m[5];

@m = (0xff, 0x03, @m); # magic prefix (see docs)
$m = pack("C*", @m).pack("S<", crc_ccitt(0xffff, @m) ^ 0xffff);
#byte stuff
$m =~ s/\x7d/\x7d\x5d/g;
$m =~ s/\x7e/\x7d\x5e/g;
$s->syswrite("\x7e".$m."\x7e") || die "Can't write message";

# read back a whole frame 
$sel=IO::Select->new($s);
do {
	if (!$sel->can_read(1.25)) { # More than enough as the ms specified
		# timed out
		warn "Timeout reading reply";
		return undef;
	}
	($bytes = $s->sysread($p, 255)) || die "Can't read reply";
	$r.=$p;
} while(($r !~ /\x7e.+\x7e/s) && $bytes) ;
if (!$bytes ) { warn "EOF or error while reading"; return undef; };

$r=substr($r,1,-1);
#unstuff
$r =~ s/\x7d\x5e/\x7e/g;
$r =~ s/\x7d\x5d/\x7d/g;
# TODO: more sophisticated error checking analysis
@r = unpack("C*",$r);
if (crc_ccitt(0xffff, @r) != 0xf0b8) {
	warn "Bad Checksum in reply: ".hexb(@r);
	return undef;
};
@r = splice(@r,2,-2);
@dstr = @r[2,3];
if (!aeq(0+@srcm, @srcm, 0+@dstr, @dstr)) {
	warn "destination does not match: ".hexb(@r);
	return undef;
}
$rt=$r[5];
if (($mt ^ $rt) != 0x80) {
	warn "type error in reply: ".hexb(@r);
	return undef;
}
return @r;
}

sub _ping {
my ($io) = shift;
my ($srcn, $srcs, $srca) = (shift, shift, shift);
my ($dstn, $dsts, $dsta) = (shift, shift, shift);
my ($bs, $bd);
my (@m, @r);

$bs = ($srcn << 4 | $srcs) & 0xff;
$bd = ($dstn << 4 | $dsts) & 0xff;

@m = ($bs, $srca & 0xff, $bd, $dsta & 0xff, 0x00, 0x15);
@r = rw($io, @m);

return 0 if (!$#r);

#print "Request: ".hexb(@m)."\n";
#print "Reply:   ".hexb(@r)."\n";

return 1;
}
sub ping {
print "ping ".(_ping(@_)?"ok":"failed")."\n";
}

sub _inq {
my ($io) = shift;
my ($srcn, $srcs, $srca) = (shift, shift, shift);
my ($dstn, $dsts, $dsta) = (shift, shift, shift);
my ($bs, $bd);
my (@m, @r, @ret);

$bs = ($srcn << 4 | $srcs) & 0xff;
$bd = ($dstn << 4 | $dsts) & 0xff;

@m = ($bs, $srca & 0xff, $bd, $dsta & 0xff, 0x1d, 0x13, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff);
@r = rw($io, @m);

return undef if (!$#r);

@ret = (pack("C*",@r[6..16]), pack("C*",@r[18..28]), @r[30,31,32]);

#print "Request: ".hexb(@m)."\n";
#print "Reply:   ".hexb(@r)."\n";

return @ret;
}
sub inq {
my (@res);

@res = _inq(@_);
if (!$#res) {
	print "Query failed\n";
	return;
}

print "Product Number: ".$res[0]."\n";
print "Serial Number:  ".$res[1]."\n";
print "Net, Sub, Addr: ".$res[2].",",$res[3].",".$res[4]."\n";
}


sub _can {
my ($io) = shift;
my ($srcn, $srcs, $srca) = (shift, shift, shift);
my ($dstn, $dsts, $dsta) = (shift, shift, shift);
my ($dmod, $pi, $psi) = (shift, shift, shift);
my ($bs, $bd);
my (@m, @r);
my ($type, $res);
my (@pf) = (undef, "C", "c", "s<", "l<", "C", "S<", "L<", "f<", "aaaa", "CCCC", "S<S<");

$bs = ($srcn << 4 | $srcs) & 0xff;
$bd = ($dstn << 4 | $dsts) & 0xff;

@m = ($bs, $srca & 0xff, $bd, $dsta & 0xff, 0x0a, 0x01, 0xc8, $dmod & 0x0f, 0xd0, $pi & 0xff, $psi & 0xff, 0x80, 0x00, 0x00, 0x00, 0x00);
@r = rw($io, @m);

return undef if (!$#r);

#print "Request: ".hexb(@m)."\n";
#print "Reply:   ".hexb(@r)."\n";

# TODO: more friendly error checking
if (($r[7] & 0x0f) != 0x0d) { die "can dest not 0x0d"; }
if (($r[8] >> 4) != ($dmod & 0x0f)) { die "can src not as requested"; };
if (!aeq(2,@r[9,10],2,@m[9,10])) { die "paramater index or subindex do match match"; };
if (($r[11] & 0xf0) != 0x40) { die "Incorrect flags"; };
$type = $r[11] & 0x0f;
if (!$pf[$type]) {die "unkown data type id"; };

$res = unpack($pf[$type], pack("C*", @r[12..15]));

#print "Result: ".$res."\n";

return $res;
}
sub can {
my ($rrd) = shift;
my ($res) = _can(@_);
if (!defined $res) {
	if (! $rrd) { print "can failed for ".hexb(@_[-3..-1])."\n";}
	else { warn "can failed for ".hexb(@_[-3..-1]);}
	return ":U";
}
if (! $rrd) { print "Param ".hexb(@_[-3..-1])." is ".$res."\n"; }
return ":".$res;
}

sub scan {
my ($io) = (shift);
my ($n, $sn, $ad, $ret);
my (@nodes, @n);

$ret = _ping($io, @own, 0x0f, 0x0f, 0xff);
if (!$ret) { die "No RS485 response to broadcast"; };
for ($n=1; $n < 0x0f; $n++) { # Only Masters are on Net 0
print "n=".$n."\n";
	$ret = _ping($io, @own, $n, 0x0f, 0xff);
	if ($ret) {
		for ($sn=0; $sn < 0x0f; $sn++) {
print "n=".$n." sn=".$sn."\n";
			$ret = _ping($io, @own, $n, $sn, 0xff);
			if ($ret) {
				for ($ad=0; $ad < 0xff; $ad++) {
print "n=".$n." sn=".$sn." ad=".$ad."\n";
					$ret = _ping($io, @own, $n, $sn, $ad);
					if ($ret) {
print "found at n=".$n." sn=".$sn." ad=".$ad."\n";
						push @nodes, [$n, $sn, $ad, _inq($io, @own, @dst) ];
					}
				}
			}
		}
	}
}
foreach (@nodes) {
	@n = @{$_};
	print "Found Device at: ".$n[0].",".$n[1].",".$n[2]."\n";
	print "Product Number: ".$n[3]." Serial Number: ".$n[4]." Address: ".$n[5].",".$n[6].",".$n[7]."\n\n";
}
}

sub usage {
print "Usage:\n";
print $0." -help | -ping | -inq | -scan | (-rrd (-|<RRDFILE>) | -can) (-|<FILENAME>|<Modules>,<Index>,<Subindex>)\n";
print "\n";
print "Use -help to print this message\n";
print "Performs requested operation on the configured target.\n";
print "Use -scan to scan the whole inverter network.\n";
print "-inq, -ping, and -can work on the configured target.\n";
print "For <Modules>,<Index>,<Subindex> tuples, see ComLynxUserGuide.\n";
print "A - reads <Modules>,<Index>,<Subindex> tuples from STDIN.\n";
print "Otherwise the tuples are read from <FILENAME>.\n";
print "If <RRDFILE> is given, it will be updated\n";
print "If <RRDFILE> is -, the name while be derived from <FILENAME>";
print "If both are -, a line suitable for rrd update will be printed\n";
exit;
}

# main
my ($mode, $rrd);
my (@cana);
my ($rra, $rrt, $pfn, $rfn);

usage() if ($#ARGV < 0);
$_ = shift @ARGV;
usage() if (/^-h.*/);
$mode = "ping" if (/^-ping/);
$mode = "inq" if (/^-inq/);
$mode = "scan" if (/^-scan/);
if (/^-can/) {
	$mode = "can";
	usage() if ($#ARGV < 0);
	$pfn = shift @ARGV;
}
if (/^-rrd/) {
	$mode = "can";
	usage() if ($#ARGV < 0);
	$rfn = shift @ARGV;
	usage() if ($#ARGV < 0);
	$pfn = shift @ARGV;
}
usage() if (!$mode);
usage() if ($#ARGV >= 0);

if ($mode eq "can") {
	my (@ds);

	@ds = ($pfn =~ /^([^# ]+),([^# ]+),([^# ]+)/);
	if ($#ds < 0) {
		# - for stdin in builtin for perl open
		open(PARMS, "<".$pfn) or die "Can't open parmfile\n";
		while(<PARMS>) {
			next if /^[ \t]*#/;
			push(@cana, [/^([^# ]+),([^# ]+),([^# ]+)/]);
			usage() if (!$cana[-1][0]);
		}
		close(PARMS);
	} else {
		$pfn = "-";
		push(@cana, [ @ds ]);
	}
	usage() if (!$cana[0][0]);
}
if ($rfn) {
	if ($rfn eq "-") {
		if ($pfn eq "-") {
			$rrd = 1;
		} else {
			$rfn = $pfn;
			$rfn =~ s/.parms//;
			$rfn .= ".rrd";
			$rrd = 2;
		}
	}
	else {
		$rrd = 2;
	}
} else {
	$rrd = 0;
}

$io = make_io();
ping($io, @own, @dst) if ($mode eq "ping");
inq($io, @own, @dst) if ($mode eq "inq");
scan($io) if ($mode eq "scan");
if ($mode eq "can") {
	$rra = "N";
	foreach (@cana) {
		my (@ds) = (map{(/^0/)?oct:(/^[0-9]+$/)?int:0} @$_);
		$rrt .= ":".hexb_(@ds);
		$rra .= can($rrd, $io, @own, @dst, @ds);
	}
	$rrt =~ s/^://;
	print "--template ".$rrt." -- ".$rra."\n" if ($rrd == 1);
	if ($rrd == 2) {
		RRDs::update($rfn, "--template", $rrt, $rra);
		my $rrderr = RRDs::error;
		die "Error while updating $rfn: $rrderr" if ($rrderr);
	}
}
$io->close();
exit;
