fhem-mirror/FHEM/00_KNXTUL.pm
2019-12-30 10:43:45 +00:00

689 lines
17 KiB
Perl

##############################################
#$Id$
#31.01.2019: Checked Message Format to prevent FHEM-Crash
#13.03.2019: Let only normal (no System-Messages) pass to prevent Creating Fake-Devices
package main;
use strict;
use warnings;
use Time::HiRes qw(gettimeofday);
use IO::Socket::INET;
my $KNXTUL_hasMulticast = 1;
sub KNXTUL_Attr(@);
sub KNXTUL_Clear($);
sub KNXTUL_Parse($$$$$);
sub KNXTUL_Read($);
sub KNXTUL_Ready($);
sub KNXTUL_Write($$$);
sub KNXTUL_OpenDev($$);
sub KNXTUL_CloseDev($);
sub KNXTUL_Disconnected($);
sub KNXTUL_Shutdown($);
my %gets = ( # Name, Data to send to the TUL, Regexp for the answer
"raw" => ["r", '.*'],
);
my %sets = (
"raw" => "",
);
sub KNXTUL_Initialize($)
{
my ($hash) = @_;
eval("use IO::Socket::Multicast");
$KNXTUL_hasMulticast = 0 if($@);
# Provider
$hash->{ReadFn} = "KNXTUL_Read";
$hash->{WriteFn} = "KNXTUL_Write";
$hash->{ReadyFn} = "KNXTUL_Ready";
# Normal devices
$hash->{DefFn} = "KNXTUL_Define";
$hash->{UndefFn} = "KNXTUL_Undef";
$hash->{StateFn} = "KNXTUL_SetState";
$hash->{AttrFn} = "KNXTUL_Attr";
$hash->{AttrList}= "do_not_notify:1,0 " .
"dummy:1,0 " .
"showtime:1,0 " .
"verbose:0,1,2,3,4,5 ";
$hash->{ShutdownFn} = "KNXTUL_Shutdown";
}
#####################################
sub KNXTUL_Define($$)
{
my ($hash, $def) = @_;
my @a = split("[ \t][ \t]*", $def);
my $argcount=scalar(@a);
if($argcount < 3)
{
my $msg = "wrong syntax: define <name> KNXTUL <knx addr>";
return $msg;
}
return "install IO::Socket::Multicast to use KNXTUL" if(!$KNXTUL_hasMulticast);
$hash->{"HAS_IO::Socket::Multicast"} = $KNXTUL_hasMulticast;
KNXTUL_CloseDev($hash);
my $name = $a[0];
my $devaddr = KNXTUL_str2hex($a[2]);
$hash->{DeviceAddress} = $devaddr;
if ($argcount<4) {
$hash->{IPAddress} = "224.0.23.12";
$hash->{UseDirectConnection}=0;
} else {
$hash->{IPAddress}= $a[3];
$hash->{UseDirectConnection}=1;
}
$hash->{Port} = 3671;
$hash->{Clients} = "KNX";
my $ret = KNXTUL_OpenDev($hash, 0);
return $ret;
}
########################
sub KNXTUL_OpenDev($$)
{
my ($hash, $reopen) = @_;
my $name = $hash->{NAME};
my $host = $hash->{IPAddress};
my $port = $hash->{Port};
my $UseDirectConnection = $hash->{UseDirectConnection};
$hash->{PARTIAL} = "";
Log 3, "KNXTUL opening $name" if(!$reopen);
# This part is called every time the timeout (5sec) is expired _OR_
# somebody is communicating over another TCP connection. As the connect
# for non-existent devices has a delay of 3 sec, we are sitting all the
# time in this connect. NEXT_OPEN tries to avoid this problem.
return if($hash->{NEXT_OPEN} && time() < $hash->{NEXT_OPEN});
my $conn=0;
if ($UseDirectConnection) {
$conn = new IO::Socket::INET(PeerHost => $host,PeerPort=>$port,Proto=>'udp') or Log3($name,0,"Connection to ".$host." can't be established");
} else {
$conn = IO::Socket::Multicast->new(Proto=>'udp',LocalPort=>$port,LocalAddr=>$host,ReuseAddr=>1);
$conn->mcast_add($host) || Log3 ($name, 3,"Can't set group: $host");
$conn->mcast_dest($host.":".$port);
}
if($conn)
{
delete($hash->{NEXT_OPEN})
}
else
{
Log3 ($name, 3, "Can't connect: $!") if(!$reopen);
$readyfnlist{"$name"} = $hash;
$hash->{STATE} = "disconnected";
$hash->{NEXT_OPEN} = time()+60;
return "";
}
$hash->{CD} = $conn;
$hash->{FD} = $conn->fileno();
delete($readyfnlist{"$name"});
$selectlist{"$name"} = $hash;
if($reopen)
{
Log3 ($name, 1, "KNXTUL reappeared ($name)");
}
else
{
Log3 ($name, 3, "KNXTUL device opened");
}
$hash->{STATE}=""; # Allow InitDev to set the state
my $ret = KNXTUL_DoInit($hash);
if($ret)
{
KNXTUL_CloseDev($hash);
Log (1, "OpenDev: Cannot init KNXTUL-Device, ignoring it");
}
DoTrigger($name, "CONNECTED") if($reopen);
return $ret;
}
#####################################
# called from the global loop, when the select for hash->{FD} reports data
sub KNXTUL_Read($)
{
my ($hash) = @_;
#reset the refused flag, so we can check if a telegram was refused
$hash->{REFUSED} = undef;
my $buf = "";
my $name = $hash->{NAME};
my $outbuf="";
my $len=$hash->{CD}->recv($buf, 1024);
Log3($name,5,"KNXTUL - Read started");
if (defined($hash->{CHUNK}))
{
$buf=$hash->{CHUNK}.$buf;
$hash->{CHUNK}=undef;
}
if( !defined($len) || !$len ) {
Log3($name,1,"KNXTUL - No Data at Read");
} else {
my $header_size=unpack("C",$buf);
if (length($buf)<$header_size)
{
$hash->{CHUNK}=$buf;
return "";
}
my $total_length=unpack("x4n",$buf);
if (length($buf)<$total_length)
{
$hash->{CHUNK}=$buf;
return "";
} elsif (length($buf)>$total_length) {
$hash->{CHUNK}=substr($buf,$total_length);
$buf=substr($buf,0,$total_length);
}
my $message=substr($buf,$header_size);
my $hexmessage=unpack("H*",$message);
if (length($message)<11) {
Log3($name,5,"Received Message too short: ".$hexmessage);
return "";
}
if (substr($hexmessage,0,6) ne "2900bc") {
Log3($name,5,"No useable Messageheader: ".substr($hexmessage,0,4));
return "";
}
Log3($name,5,"RawMessage read: ".unpack("H*",$message));
#8Bit ControlByte, 16 Bit SourceAddress, 16 Bit TargetAddress, 1 Bit 1=Groupaddress 0=physical Address, 3 Bit Rounting Count, 4 Bit length of Information
my $bindata=unpack("B*",$message);
my ($ctrlbyte,$src,$dst,$len,$data)=unpack("x3aa2a2B8a*",$message);
my $rcvmessage=$src.$dst.$data;
$len=oct("0b0000".substr($len,4,4))+1;
if ($len!=length($data)) {
Log3($name,1,"Data-Length invalid: should be ".$len." is ".length($data));
return "";
}
Log3($name,5,"Message read - CtrlByte: ".unpack("B*",$ctrlbyte)." Source: ".unpack("H*",$src)." Dest: ".unpack("H*",$dst)." Data: ".unpack("H*",$data));
my $eibdata=KNXTUL_decode_eibd($rcvmessage);
my $type = $eibdata->{'type'};
$dst = $eibdata->{'dst'};
$src = $eibdata->{'src'};
my @bindata = @{$eibdata->{'data'}};
$data = "";
# convert bin data to hex
foreach my $c (@bindata)
{
$data .= sprintf ("%02x", $c);
}
$outbuf = $src;
if ($type eq "write") {$outbuf .= "w";}
elsif ($type eq "read") {$outbuf .= "r";}
else {$outbuf .= "p";}
$outbuf .= $dst;
$outbuf .= $data;
}
# check if refused
if(defined($hash->{REFUSED}))
{
Log3 ($name, 3,"KNXTUL $name refused message: $hash->{REFUSED}");
$hash->{REFUSED} = undef;
return "";
}
if(!defined($buf) || length($buf) == 0)
{
KNXTUL_Disconnected($hash);
return "";
}
#place KNX-Message
KNXTUL_Parse($hash, $hash, $name, "C".$outbuf, $hash->{initString});
}
#####################################
sub KNXTUL_Undef($$)
{
my ($hash, $arg) = @_;
my $name = $hash->{NAME};
foreach my $d (sort keys %defs)
{
if(defined($defs{$d}) && defined($defs{$d}{IODev}) && $defs{$d}{IODev} == $hash)
{
my $lev = ($reread_active ? 4 : 2);
Log (GetLogLevel($name,$lev), "deleting port for $d");
delete $defs{$d}{IODev};
}
}
KNXTUL_CloseDev($hash);
return undef;
}
#####################################
sub KNXTUL_Shutdown($)
{
my ($hash) = @_;
KNXTUL_CloseDev($hash);
return undef;
}
#####################################
sub KNXTUL_SetState($$$$)
{
my ($hash, $tim, $vt, $val) = @_;
return undef;
}
sub KNXTUL_Clear($)
{
my $hash = shift;
#Clear the pipe
#TUL has no pipe....
}
#####################################
sub KNXTUL_DoInit($)
{
my $hash = shift;
my $name = $hash->{NAME};
my $err;
KNXTUL_Clear($hash);
$hash->{STATE} = "Initialized" if(!$hash->{STATE});
# Reset the counter
delete($hash->{XMIT_TIME});
delete($hash->{NR_CMD_LAST_H});
return undef;
}
#####################################
sub KNXTUL_Parse($$$$$)
{
my ($hash, $iohash, $name, $rmsg, $initstr) = @_;
# there is nothing specal to do at the moment.
# just dispatch
my $dmsg = $rmsg;
$hash->{"${name}_MSGCNT"}++;
$hash->{"${name}_TIME"} = TimeNow();
$hash->{RAWMSG} = $rmsg;
my %addvals = (RAWMSG => $rmsg);
Dispatch($hash, $dmsg, \%addvals);
}
#####################################
sub KNXTUL_Ready($)
{
my ($hash) = @_;
return KNXTUL_OpenDev($hash, 1) if($hash->{STATE} eq "disconnected");
}
########################
sub KNXTUL_Write($$$)
{
my ($hash,$fn,$msg) = @_;
return if(!$hash);
my $name = $hash->{NAME};
Log3($name,5,"KNXTUL - Write started");
return if(!defined($fn));
# Discard message if TUL is disconnected
return if($hash->{STATE} eq "disconnected");
Log3 ($name, 5, "KNXTUL: sending $fn $msg");
$msg = "$fn$msg";
# Msg must have the format B(w,r,p)g1g2g3v....
# w-> write, r-> read, p-> reply
# g1,g2,g3 are the hex parts of the group name
# v is a simple (1 Byte) or complex value (n bytes)
if ($msg =~ /^[BC](.)(.{5})(.*)$/)
{
my $eibmsg;
if($1 eq "w")
{
$eibmsg->{'type'} = 'write';
}
elsif ($1 eq "r")
{
$eibmsg->{'type'} = 'read';
}
elsif ($1 eq "p")
{
$eibmsg->{'type'} = 'reply';
}
$eibmsg->{'dst'} = $2;
my $hexvalues = $3;
#The array has to have a given length. During Hex-conversion Trailing
#0 are recognizes for warnings.
#Therefore we backup the length, trim, and reappend the 0
#
#save length and trim right side
my $strLen = length ($hexvalues) / 2;
$hexvalues =~ s/\s+$//;
#convert hex-string to array with dezimal values
my @data = map hex($_), $hexvalues =~ /(..)/g;
#re-append 0x00
for (my $i=0; $strLen - scalar @data; $i++)
{
push (@data, 0);
}
# check: first byte is only allowed to contain data in the lower 6bits
# to make sure all is fine, we mask the first byte
$data[0] = $data[0] & 0x3f if(defined($data[0]));
$eibmsg->{'data'} = \@data;
KNXTUL_sendGroup($hash, $eibmsg);
}
else
{
Log3 ($hash->{NAME}, 1,"Could not parse message $msg");
return undef;
}
select(undef, undef, undef, 0.001);
}
sub KNXTUL_sendGroup($$)
{
my ($hash,$msgref) = @_;
my $dst = $msgref->{'dst'};
my $src = $hash->{DeviceAddress};
$msgref->{'src'} = $src;
my @encmsg = KNXTUL_encode_eibd($hash,$msgref);
Log3($hash->{NAME},5,"KNXTUL_sendGroup: dst: $dst, msg: @encmsg \n");
my $str=pack("nCC*", @encmsg);
my $host = $hash->{IPAddress};
my $port = $hash->{Port};
my $size = length($str);
my $completemsg=pack("H*","06100530").pack("n",$size+12).pack("H*","2900BCD0").pack("n",$size).$str;
Log3 ($hash->{NAME},5,"KNXTUL_sendRequest: ".$host.":".$port." msg: ".unpack("H*",$completemsg). "\n");
return undef unless $hash->{CD}->mcast_send($completemsg,$host.":".$port);
return 1;
}
########################
sub KNXTUL_CloseDev($)
{
my ($hash) = @_;
my $name = $hash->{NAME};
my $dev = $hash->{DeviceName};
return if(!$dev);
if($hash->{FD})
{
$hash->{FD}->close();
delete($hash->{FD});
}
elsif($hash->{USBDev})
{
$hash->{USBDev}->close() ;
delete($hash->{USBDev});
}
delete($selectlist{"$name.$dev"});
delete($readyfnlist{"$name.$dev"});
delete($hash->{FD});
}
########################
sub KNXTUL_Disconnected($)
{
my $hash = shift;
my $name = $hash->{NAME};
return if(!defined($hash->{FD})); # Already deleted or RFR
Log3 ($name, 1, "KNXTUL disconnected, waiting to reappear");
KNXTUL_CloseDev($hash);
$readyfnlist{"$name"} = $hash; # Start polling
$hash->{STATE} = "disconnected";
# Without the following sleep the open of the device causes a SIGSEGV,
# and following opens block infinitely. Only a reboot helps.
sleep(5);
DoTrigger($name, "DISCONNECTED");
}
########################
sub KNXTUL_Attr(@)
{
my ($cmd,$name,$aName,$aVal) = @_;
Log3 ($name, 5, "changing value, ATTR: $aName, VALUE: $aVal");
return undef;
}
# Utility functions
sub KNXTUL_hex2addr
{
my $str = lc($_[0]);
if ($str =~ /([0-9a-f]{2})([0-9a-f])([0-9a-f]{2})/)
{
return (hex($1) << 11) | (hex($2) << 8) | hex($3);
}
else
{
return;
}
}
sub KNXTUL_addr2hex
{
my $a = $_[0];
my $b = $_[1]; # 1 if local (group) address, else physical address
my $str ;
if ($b == 1)
{
#logical address used
$str = sprintf "%02x%01x%02x", ($a >> 11) & 0x1f, ($a >> 8) & 0x7, $a & 0xff;
}
else
{
$str = sprintf "%02x%01x%02x", $a >> 12, ($a >> 8) & 0xf, $a & 0xff;
}
return $str;
}
sub KNXTUL_str2hex
{
my $str = $_[0];
my $hex;
if (($str =~ /(\d+)\/(\d+)\/(\d+)/) or ($str =~ /(\d+)\.(\d+)\.(\d+)/))
{
# logical address
$hex = sprintf("%02x%01x%02x",$1,$2,$3);
return $hex;
}
}
# For mapping between APCI symbols and values
my @apcicodes = ('read', 'reply', 'write');
my %apcivalues = ('read' => 0, 'reply' => 1, 'write' => 2,);
# decode: unmarshall a string with an EIB message into a hash
# The hash has the follwing fields:
# - type: APCI (symbolic value)
# - src: source address
# - dst: destiniation address
# - data: array of integers; one for each byte of data
sub KNXTUL_decode_eibd($)
{
my ($buf) = @_;
my $drl = 0xe1; # dummy value
my %msg;
my @data;
my ($src, $dst,$bytes) = unpack("nnxa*", $buf);
my $apci;
$apci = vec($bytes, 3, 2);
# mask out apci bits, so we can use the whole byte as data:
vec($bytes, 3, 2) = 0;
if ($apci >= 0 && $apci <= $#apcicodes)
{
$msg{'type'} = $apcicodes[$apci];
}
else
{
$msg{'type'} = 'apci ' . $apci;
}
$msg{'src'} = KNXTUL_addr2hex($src,0);
$msg{'dst'} = KNXTUL_addr2hex($dst,1);
@data = unpack ("C" . length($bytes), $bytes);
my $datalen = @data;
Log (5, "KNXTUL_decode_eibd: byte len: " . length($bytes) . " array size: $datalen");
# in case of data len > 1, the first byte (the one with apci) seems not to be used
# and only the following byte are of interest.
if($datalen>1)
{
shift @data;
}
$msg{'data'} = \@data;
return \%msg;
}
# encode: marshall a hash into a EIB message string
sub KNXTUL_encode_eibd($$)
{
my ($hash,$mref) = @_;
my @msg;
my $APCI;
my @data;
$APCI = $apcivalues{$mref->{'type'}};
if (!(defined $APCI))
{
Log3($hash->{NAME},3,"KNXTUL_encode_eibd: Bad KNX message type $mref->{'type'}\n");
return;
}
@data = @{$mref->{'data'}};
@data = (0x0) if(!@data || !defined($data[0])); #make sure data has at least one element
my $datalen = @data;
Log3 ($hash->{NAME},5,"KNXTUL_encode_eibd: dst: $mref->{'dst'} apci: $APCI datalen: $datalen data: @data");
@msg = (
KNXTUL_hex2addr( $mref->{'dst'}), # Destination address
$datalen,
0x0 | ($APCI >> 2), # TPDU type, Sequence no, APCI (msb)
(($APCI & 0x3) << 6) | $data[0],
);
if ($datalen > 1)
{
shift(@data);
push @msg, @data;
}
return @msg;
}
1;
=pod
=begin html
<a name="KNXTUL"></a>
<h3>KNXTUL</h3>
<ul>
The KNXTUL module is the representation of a EIB / KNX connector in FHEM without the need for knxd or similar.
<a href="#KNX">KNX</a> instances represent the EIB / KNX devices and will need a KNXTUL as IODev to communicate with the EIB / KNX network.<br>
The TUL module is designed to connect to KNX network via Standard Multicast Address (224.0.23.12)
Note: This module requires Perl Module IO::Socket::Multicast which needs to be installed before use.
<a name="KNXTULdefine"></a>
<b>Define</b>
<ul>
<code>define &lt;name&gt; KNXTUL &lt;physical address&gt;</code> <br>
<br>
<ul>
<br><br>
Example:<br>
<code>define tul KNXTUL 1.1.249</code>
</ul>
<br>
The physical address is used as the source address of telegrams sent to EIB network.
</ul>
<br>
<a name="TULattr"></a>
<b>Attributes</b>
<ul>
<li><a href="#do_not_notify">do_not_notify</a></li><br>
<li><a href="#attrdummy">dummy</a></li><br>
<li><a href="#showtime">showtime</a></li><br>
<li><a href="#verbose">verbose</a></li><br>
</ul>
<br>
</ul>
=end html
=device
=item summary Connects FHEM to KNX-Bus (Base-device)
=item summary_DE Verbindet FHEM mit dem KNX-Bus (Basisger&umlat)
=begin html_DE
<a name="KNXTUL"></a>
<h3>KNXTUL</h3>
<ul>
Das Modul KNXTUL stellt die Verbindung von FHEM zu KNX dar.
<a href="#KNX">KNX</a> Instanzen stellen die Vrbindung zu den KNX-Gruppen dar und ben&ouml;tigen ein TUL-Device als IO-Schnittstelle.<br>
Das Modul KNXTUL kommuniziert mit dem KNX über die KNX-Multicast-Adresse 224.0.23.12. Voraussetzung ist ein KNX/IP-Router im selben Netztwerk wie die FHEM-Instanz.
Anmerkung: das Modul ben&ouml;tigt das Perl Modul IO::Socket::Multicast.
<a name="KNXTULdefine"></a>
<b>Define</b>
<ul>
<code>define &lt;name&gt; KNXTUL &lt;Physikalische KNX-Adresse&gt;</code> <br>
<br>
Beispiel:<br>
<code>define tul KNXTUL 1.1.249</code>
<br>
Die physikalische Adresse wird als Absender f&uuml;r KNX-Telegramme genutzt.
</ul>
<br>
<a name="TULattr"></a>
<b>Attribute</b>
<ul>
<li><a href="#do_not_notify">do_not_notify</a></li><br>
<li><a href="#attrdummy">dummy</a></li><br>
<li><a href="#showtime">showtime</a></li><br>
<li><a href="#verbose">verbose</a></li><br>
</ul>
<br>
</ul>
=end html_DE
=cut