diff --git a/fhem/FHEM/98_Modbus.pm b/fhem/FHEM/98_Modbus.pm index 6e12da04f..24877b499 100755 --- a/fhem/FHEM/98_Modbus.pm +++ b/fhem/FHEM/98_Modbus.pm @@ -60,19 +60,47 @@ # busDelay, clientSwitchDelay, dropQueueDoubles # new attrs on the logical device: alignTime, enableControlSet # 2016-06-30 use non blocking open, new attrs: nextOpenDelay, maxTimeoutsToReconnect, disable +# 2016-08-13 textArg, fehler bei showGet, umstellung der Prüfungen bei Get und Set (controlSet, ?, ...) +# open / reconnect handling komplett überarbeitet +# 2016-08-20 textArg fehlte noch in der Liste der erlaubten Attribute +# 2016-09-20 fixed bug in define when destination was undefined (introduced in preparation for Modbus ASCII) +# 2016-10-02 first version with Modbus ASCII support, disable attribute closes Modbus connections over TCP +# 2016-10-08 revRegs und bswapRegs in Send eingebaut, bugs bei revRegs / bswapRegs behoben +# validate interval in define and set interval, restructured Opening of connections +# 2016-11-17 fixed missing timer set in Notify when rereadcfg is seen, +# accept Responses from different ID after a broadcast +# 3.5.1 restructure set / send for unpack and revRegs / swapRegs +# 2016-11-20 restructured parseFrames and its calls / returns +# optimized logging, fixed bugs with RevRegs # -# TODO: +# +# +# ToDo / Ideas : +# +# scanner für ids +# don't insist on h1 instead of h001 (check with added 0's)? +# scanner für objekte, range in attrs erzeugt gefundene attr objekte und reading +# mit Format varianten - siehe ipad notizen +# passive listening to other modbus traffic (state machine, parse requests of others in special queue +# test modbus tcp ohne dass ein physische gerät existiert +# +# Länge der Antwort bei fcode 3 und 4 aus der angefragten Länge ermitteln und +# dann erst bei genügend Bytes crc prüfen. +# bzw. len aus unpack ableiten oder Meldung wenn zu klein +# +# todos in parseframes und parseobj geschrieben +# +# transform LD_Send to _Send (physical, only getting info from logical) +# move framing from send to handlesendqueue +# +# nonblocking disable attr für xp +# set definition with multiple requests as raw containig opt. readings / input # attr prüfungen bei attrs, die nur für TCP sinnvoll sind -> ist es ein TCP Device? -# revRegs und bswapRegs for writing values -# set textarg mit @a ab 2, # map mit spaces wie bei HTTPMOD -# len aus unpack ableiten oder Meldung wenn zu klein # :noArg etc. für Hintlist und userattr wie in HTTPMOD optimieren # Input validation for define if interval is not numeric but TCP ... -# TCP Disconnect / Reconnect testen / ggf. optimieren -# physical device busDelay clientSwitchDelay -# module version internal? -# userattr handling for wildcard attributes like in HTTPMOD +# +# addToDevAttrList handling for wildcard attributes like in HTTPMOD # Autoconfigure? (Combine testweise erhöhen, Fingerprinting -> DB?, ...?) # # @@ -111,7 +139,7 @@ sub ModbusLD_GetUpdate($); sub ModbusLD_GetIOHash($); sub ModbusLD_Send($$$;$$$); -my $Modbus_Version = '3.3.1 - 18.7.2016'; +my $Modbus_Version = '3.5.1 - 21.11.2016'; my %errCodes = ( "01" => "illegal function", @@ -169,17 +197,22 @@ Modbus_Initialize($) ##################################### -# Define für das physische Basismodul +# Define für das physische serielle Basismodul # modbus id, Intervall etc. gibt es hier nicht # sondern im logischen Modul. +# # entsprechend wird auch getUpdate im # logischen Modul aufgerufen. -sub -Modbus_Define($$) +# +# Modbus over TCP is opened in the logical open +# +sub Modbus_Define($$) { my ($ioHash, $def) = @_; my @a = split("[ \t]+", $def); my ($name, $type, $dev) = @a; + my $ret; + return "wrong syntax: define $type [tty-devicename|none]" if(@a < 1); @@ -193,13 +226,16 @@ Modbus_Define($$) return undef; } $ioHash->{DeviceName} = $dev; # needed by DevIo to get Device, Port, Speed etc. - return DevIo_OpenDev($ioHash, 0, 0); + DevIo_OpenDev($ioHash, 0, 0); # open physical device blocking (no nonblockingt TCP stuff here) + + return $ioHash->{FD} ? undef : "$dev could not be openend yet" . ($ret ? ". $ret" : ""); + } ##################################### -sub -Modbus_Undef($$) +# delete physical Device # todo: check other callback functions (undef, delete, shutdown) +sub Modbus_Undef($$) { my ($ioHash, $arg) = @_; my $name = $ioHash->{NAME}; @@ -208,13 +244,61 @@ Modbus_Undef($$) RemoveInternalTimer ("queue:$name"); # lösche auch die Verweise aus logischen Modulen auf dieses physische. foreach my $d (values %{$ioHash->{defptr}}) { - Log3 $name, 3, "removing IO device for $d->{NAME}"; + Log3 $name, 3, "$name: Undef is removing IO device for $d->{NAME}"; delete $d->{IODev}; RemoveInternalTimer ("update:$d->{NAME}"); } return undef; } + +######################################################## +# Notify for INITIALIZED -> Open defined logical device +# +# Bei jedem Define erzeugt Fhem.pl ein $hash{NTFY_ORDER} für das +# Device falls im Modul eine NotifyFn gesetzt ist. +# +# bei jedem Define, Rename oder Modify wird der interne Hash %ntfyHash +# gelöscht und beim nächsten Event in createNtfyHash() neu erzeugt +# wenn er nicht existiert. +# +# Im %ntfyHash wird dann für jede mögliche Event-Quelle als Key auf die Liste +# der Event-Empfänger verwiesen. +# +# die createNtfyHash() Funktion schaut für jedes Device nach $hash{NOTIFYDEV} +# falls existent wird das Gerät nur für die in $hash{NOTIFYDEV} aufgelisteten +# Event-Erzeuger in deren ntfyHash-Eintrag es Evet-Empfänger aufgenommen. +# +# Um ein Gerät als Event-Empfänger aus den Listen mit Event-Empfängern zu entfernen +# könnte man $hash{NOTIFYDEV} auf "," setzen und %ntfyHash auf () löschen... +# +# im Modul die NotifyFn zu entfernen würde den Aufruf verhindern, aber +# $hash{NTFY_ORDER} bleibt und daher erzeugt auch createNtfyHash() immer wieder verweise +# auf das Gerät, obwohl die NotifyFn nicht mehr regisrtiert ist ... +# +# +sub ModbusLD_Notify($$) +{ + my ($hash, $source) = @_; + my $name = $hash->{NAME}; # my Name + my $sName = $source->{NAME}; # Name of Device that created the events + return if($sName ne "global"); # only interested in global Events + + my $events = deviceEvents($source, 1); + return if(!$events); # no events + + # Log3 $name, 5, "$name: Notify called for source $source->{NAME} with events: @{$events}"; + return if (!grep(m/^INITIALIZED|REREADCFG$/, @{$events})); + + if ($hash->{DEST} && !AttrVal($name, "disable", undef)) { + Modbus_Open($hash); + } + ModbusLD_SetTimer($hash, 1); # first Update in 1 second or aligned + + return; +} + + ################################################ # Get Object Info from Attributes, # parseInfo Hash or default from deviceInfo Hash @@ -326,9 +410,11 @@ ModbusLD_ObjKey($$) { } -##################################### +################################################# # Parse holding / input register / coil Data -# called from read via parseframes +# only called from parseframes +# which is only called from read / readanswer +# # with logical device hash, data string # and the object hash ref to start with sub @@ -341,13 +427,14 @@ Modbus_ParseObj($$$;$) { my $type = substr($objCombi, 0, 1); my $startAdr = substr($objCombi, 1); my $lastAdr = ($quantity ? $startAdr + $quantity -1 : 0); - my ($unpack, $format, $expr, $map, $revRegs, $bswapRegs, $rest, $len, $encode, $decode); + my ($unpack, $format, $expr, $map, $rest, $len, $encode, $decode); Log3 $name, 5, "$name: ParseObj called with " . unpack ("H*", $data) . " and start $startAdr" . ($quantity ? ", quantity $quantity" : ""); if ($type =~ "[cd]") { + # quantity is only used for coils / discrete inputs $quantity = 1 if (!$quantity); $rest = unpack ("b$quantity", $data); # convert binary data to bit string - Log3 $name, 5, "$name: ParseObj bit string: " . $rest . " and start $startAdr, quantity $quantity"; + Log3 $name, 5, "$name: ParseObj shortened bit string: " . $rest . " and start adr $startAdr, quantity $quantity"; } else { $rest = $data; } @@ -361,47 +448,24 @@ Modbus_ParseObj($$$;$) { if ($type =~ "[cd]") { $unpack = "a"; # for coils just take the next 0/1 from the string $len = 1; # one byte contains one bit from the 01 string unpacked above - $revRegs = 0; # not applicable - $bswapRegs = 0; # not applicable } else { - $unpack = ModbusLD_ObjInfo($logHash, $key, "unpack", "defUnpack", "n"); # default to big endian unsigned int - $len = ModbusLD_ObjInfo($logHash, $key, "len", "defLen", 1); # default to 1 Reg / 2 Bytes - $revRegs = ModbusLD_ObjInfo($logHash, $key, "revRegs", "defRevRegs"); # do not reverse register order by default - $bswapRegs = ModbusLD_ObjInfo($logHash, $key, "bswapRegs", "defBswapRegs"); # dont reverse bytes in registers by default - $encode = ModbusLD_ObjInfo($logHash, $key, "encode", "defEncode"); # character encoding - $decode = ModbusLD_ObjInfo($logHash, $key, "decode", "defDecode"); # character decoding - if ($revRegs && $len > 1) { - Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading: reversing order of registers before unpacking"; - my $p1 = substr($rest, 0, $len * 2); # the first len bytes - my $p2 = substr($rest, $len * 2); # everything after len - my $pn = ""; - while ($p1) { - $pn = substr($p1, 0, 2) . $pn; - $p1 = substr($p1, 2); - } - Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading: data string before is " . unpack ("H*", $rest); - $rest = $pn . $p2; - Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading: data string after is " . unpack ("H*", $rest); - } else { - #Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading: NOT reversing order of registers, revRegs = $revRegs, len = $len "; - } - if ($bswapRegs && $len > 1) { - Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading: reversing byte order of registers before unpacking"; - my $nval = ""; - for (my $i = 0; $i < $len; $i++) { - $nval = $nval . substr($rest,$i*2 + 1,1) . substr($rest,$i*2,1); - }; - Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading: data string before is " . unpack ("H*", $rest); - $rest = $nval; - Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading: data string after is " . unpack ("H*", $rest); - } + $unpack = ModbusLD_ObjInfo($logHash, $key, "unpack", "defUnpack", "n"); # default to big endian unsigned int + $len = ModbusLD_ObjInfo($logHash, $key, "len", "defLen", 1); # default to 1 Reg / 2 Bytes + $encode = ModbusLD_ObjInfo($logHash, $key, "encode", "defEncode"); # character encoding + $decode = ModbusLD_ObjInfo($logHash, $key, "decode", "defDecode"); # character decoding + my $revRegs = ModbusLD_ObjInfo($logHash, $key, "revRegs", "defRevRegs"); # do not reverse register order by default + my $swpRegs = ModbusLD_ObjInfo($logHash, $key, "bswapRegs", "defBswapRegs"); # dont reverse bytes in registers by default + + $rest = Modbus_RevRegs($logHash, $rest, $len) if ($revRegs && $len > 1); + $rest = Modbus_SwpRegs($logHash, $rest, $len) if ($swpRegs); }; $format = ModbusLD_ObjInfo($logHash, $key, "format", "defFormat"); # no format if nothing specified $expr = ModbusLD_ObjInfo($logHash, $key, "expr", "defExpr"); # no expr if not specified $map = ModbusLD_ObjInfo($logHash, $key, "map", "defMap"); # no map if not specified - Log3 $name, 5, "$name: ParseObj ObjInfo: reading=$reading, unpack=$unpack, expr=$expr, format=$format, map=$map"; + Log3 $name, 5, "$name: ParseObj ObjInfo for $key: reading=$reading, unpack=$unpack, expr=$expr, format=$format, map=$map"; my $val = unpack ($unpack, $rest); # verarbeite so viele register wie passend (ggf. über mehrere Register) + Log3 $name, 5, "$name: ParseObj unpacked " . unpack ('H*', $rest) . " with $unpack to " . unpack ('H*', $val); $val = decode($decode, $val) if ($decode); $val = encode($encode, $val) if ($encode); @@ -435,13 +499,21 @@ Modbus_ParseObj($$$;$) { # gehe zum nächsten Wert if ($type =~ "[cd]") { $startAdr++; - $rest = substr($rest, 1); + if (length($rest) > 1) { + $rest = substr($rest, 1); + } else { + $rest = ""; + } last if ($lastAdr && $startAdr > $lastAdr); } else { - $startAdr += $len; - $rest = substr($rest, $len * 2); # take rest of rest starting at len*2 until the end + $startAdr += $len; + if (length($rest) > ($len*2)) { + $rest = substr($rest, $len * 2); # take rest of rest starting at len*2 until the end + } else { + $rest = ""; + } } - Log3 $name, 5, "$name: ParseObj moves to next object, skip $len to $startAdr" if ($rest); + Log3 $name, 5, "$name: ParseObj moves to next object, skip $len to $type$startAdr" if ($rest); } readingsEndUpdate($logHash, 1); } @@ -562,165 +634,156 @@ Modbus_Profiler($$) ##################################### # Called from the read and readanswer functions with hash # of device that is reading (phys / log depending on TCP / RTU -# Get log hash depending on modbus id in Frame read if through phys hash -# returns (err, data) -sub -Modbus_ParseFrames($) +# $ioHash->{REQUEST} holds request that was last sent +# log hash is taken from last request +# return: "text" is error, 0 is ignore, 1 is finished with success +sub Modbus_ParseFrames($) { my $ioHash = shift; # hash of io device given to function my $name = $ioHash->{NAME}; # name of io device my $frame = $ioHash->{helper}{buffer}; # frame is in buffer in io hash - my $logHash = $ioHash->{REQUEST}{DEVICE}; # logical device hash is saved in io hash (or points back to self) + my $logHash = $ioHash->{REQUEST}{DEVHASH}; # logical device hash is saved in io hash (or points back to self) my $type = $ioHash->{REQUEST}{TYPE}; my $adr = $ioHash->{REQUEST}{ADR}; - my ($tid, $null, $dlen, $devAdr, $pdu, $fCode, $data, $crc, $crc2); + my $reqLen = $ioHash->{REQUEST}{LEN}; + my $reqId = $ioHash->{REQUEST}{MODBUSID}; + my $proto = $ioHash->{REQUEST}{PROTOCOL}; + my $chkLen = $reqLen * 2; # in bytes for later compare + my ($null, $dlen, $devAdr, $pdu, $fCode, $data, $eCRC, $CRC); + my $tid = 0; - if (!$logHash) { - #Log3 $name, 3, "$name: ParseFrames has no device hash in last request"; - # todo - wenn WP ausgeschaltet, dann kommt bei Read Müll und bei Readanswer endlos Müll -> hört nie auf ... - return ("no logical device identified", undef); - } - Log3 $name, 5, "$name: ParseFrames got: " . unpack ('H*', $frame); + return "got data but did not send a request - ignoring" if (!$ioHash->{REQUEST}); + #Log3 $name, 5, "$name: ParseFrames got: " . unpack ('H*', $frame); use bytes; - if ($logHash->{PROTOCOL} eq "RTU") { - # zerlege Frame in Device-Adresse, fCode und Data sowie CRC für Modbus RTU - if ($frame =~ /(..)(.+)(..)/s) { # id fCode data crc /s means treat as single line ... + if ($proto eq "RTU") { + if ($frame =~ /(..)(.+)(..)/s) { # (id fCode) (data) (crc) /s means treat as single line ... ($devAdr, $fCode) = unpack ('CC', $1); $data = $2; - $crc = unpack ('v', $3); - $crc2 = Modbus_CRC($1.$2); + $eCRC = unpack ('v', $3); # Header CRC - thats what we expect to calculate + $CRC = Modbus_CRC($1.$2); # calculated CRC of data } else { - return (undef, undef); # data still incomplete - continue reading + return undef; # data still incomplete - continue reading } - Log3 $name, 4, "$name: ParseFrames: fcode $fCode from $devAdr, data " . unpack ('H*', $data) . - " calc crc = $crc2, read = $crc" . ($crc == $crc2 ? " " : " -> mismatch!") . - " expect $ioHash->{REQUEST}{FCODE} from $logHash->{MODBUSID} for module $logHash->{NAME}"; - - if ($crc != $crc2) { - Log3 $name, 5, "$name: ParseFrames got wrong crc and returns (maybe data is still incomplete)"; - return (undef, undef); # Modbus Serial, data may still be incomplete + } elsif ($proto eq "ASCII") { + if ($frame =~ /:(..)(..)(.+)(..)\r\n/) {# : (id) (fCode) (data) (lrc) \r\n + $devAdr = hex($1); + $fCode = hex($2); + $data = pack('H*', $3); + $eCRC = hex($4); # Header CRC (LRC) + $CRC = Modbus_LRC(pack('C', $devAdr) . pack ('C', $fCode) . $data); # calculate LRC of data + } else { + return undef; # data still incomplete - continue reading } - if ($logHash->{MODBUSID} != $devAdr) { - Log3 $name, 5, "$name: ParseFrames got unexpected Device Id and returns"; - return ("wrong Device Id", undef) - } - } elsif ($logHash->{PROTOCOL} eq "TCP") { - # zerlege Frame in TID, Len, Device-Adresse, fCode und Data für Modbus TCP + + } elsif ($proto eq "TCP") { + $CRC = 0; $eCRC = 0; # for later check for all protocols (not needed for TCP) if (length($frame) < 8) { - Log3 $name, 5, "$name: ParseFrames length too small: " . length($frame); - return (undef, undef); + Log3 $name, 5, "$name: ParseFrames: length too small: " . length($frame); + return undef; } ($tid, $null, $dlen, $devAdr, $pdu) = unpack ('nnnCa*', $frame); if ($ioHash->{REQUEST}{TID} != $tid) { - Log3 $name, 5, "$name: ParseFrames got unexpected tid: tid=$tid, dlen=$dlen, id=$devAdr, rest=" . unpack ('H*', $pdu); + Log3 $name, 5, "$name: ParseFrames: wrong tid ($tid), dlen=$dlen, id=$devAdr, rest=" . unpack ('H*', $pdu); # maybe old response after timeount, maybe rest after wrong frame is the one we're looking for $frame = substr($frame, $dlen + 6); # remove wrong frame - Log3 $name, 5, "$name: ParseFrames takes rest after frame: " . unpack ('H*', $frame); + Log3 $name, 5, "$name: ParseFrames: takes rest after frame: " . unpack ('H*', $frame); if (length($frame) < 8) { - Log3 $name, 5, "$name: ParseFrames length of rest is too small: " . length($frame); - return (undef, undef); + Log3 $name, 5, "$name: ParseFrames: length of rest is too small: " . length($frame); + return undef; } ($tid, $null, $dlen, $devAdr, $pdu) = unpack ('nnnCa*', $frame); - Log3 $name, 5, "$name: ParseFrames unpacked rest as tid=$tid, dlen=$dlen, id=$devAdr, pdu=" . unpack ('H*', $pdu); + Log3 $name, 5, "$name: ParseFrames: unpacked rest as tid=$tid, dlen=$dlen, id=$devAdr, pdu=" . unpack ('H*', $pdu); if ($ioHash->{REQUEST}{TID} != $tid) { $frame = substr($frame, $dlen + 6); - Log3 $name, 5, "$name: ParseFrames still got unexpected tid"; - return ("wrong tid ($tid)", undef) + return ("got wrong tid ($tid)", undef); } - } - + } if (length($pdu) + 1 < $dlen) { - Log3 $name, 5, "$name: ParseFrames length smaller than header len $dlen: " . (length($pdu) + 1); - return (undef, undef); + Log3 $name, 5, "$name: ParseFrames: Modbus TCP PDU too small (expect $dlen): " . (length($pdu) + 1); + return undef; } - ($fCode, $data) = unpack ('Ca*', $pdu); - - Log3 $name, 4, "$name: ParseFrames: fcode $fCode from $devAdr, tid $tid, data " . unpack ('H*', $data) . - " expect $ioHash->{REQUEST}{FCODE} from $logHash->{MODBUSID}, tid $ioHash->{REQUEST}{TID} for module $logHash->{NAME}"; + ($fCode, $data) = unpack ('Ca*', $pdu); + } + + Log3 $name, 3, "$name: ParseFrames got a copy of the request sent before - looks like an echo!" + if ($frame eq $ioHash->{REQUEST}{FRAME}); - if ($logHash->{MODBUSID} != $devAdr) { - Log3 $name, 5, "$name: ParseFrames got unexpected Device Id and returns"; - return ("wrong Device Id", undef) - } - } - - if ($ioHash->{REQUEST}{FCODE} != $fCode && $fCode < 128) { - Log3 $name, 5, "$name: ParseFrames got unexpected function code and returns"; - return ("unexpected function code", undef); - } - - # frame received, now handle data - $logHash->{helper}{lrecv} = gettimeofday(); # logical module side + return "recieved frame from unexpected Modbus Id $devAdr, " . + "expecting fc $ioHash->{REQUEST}{FCODE} from $reqId for module $logHash->{NAME}" + if ($devAdr != $reqId && $reqId != 0); + + return "unexpected function code $fCode from $devAdr, ". + "expecting fc $ioHash->{REQUEST}{FCODE} from $reqId for module $logHash->{NAME}" + if ($ioHash->{REQUEST}{FCODE} != $fCode && $fCode < 128); + + # + # frame received, now handle pdu data + # + $logHash->{helper}{lrecv} = gettimeofday(); # logical module side Modbus_Profiler($ioHash, "Fhem"); + delete $logHash->{gotReadings}; # will be filled by ParseObj later - if ($fCode == 1 || $fCode == 2) { # reply to read coils / discrete inputs - my ($bytes, $coils) = unpack ('Ca*', $data); - my $rlen = length ($coils); - if ($bytes > $rlen) { - Log3 $name, 5, "$name: ParseFrames expects $bytes, got $rlen, waiting fo the remaining bytes"; - return (undef, undef); # data may be incomplete (very unlikely if not impossible ...) - } - Modbus_ParseObj($logHash, $coils, $type.$adr, $ioHash->{REQUEST}{LEN}); - Log3 $name, 5, "$name: ParseFrames done, reply to fCode 1, " . scalar keys (%{$logHash->{gotReadings}}) . " readings"; - return (undef, $coils); - } elsif ($fCode == 3 || $fCode == 4) { # reply to read holding / input registers - my ($bytes, $registers) = unpack ('Ca*', $data); - my $rlen = length ($registers); - if ($bytes > $rlen) { - Log3 $name, 5, "$name: ParseFrames expects $bytes, got $rlen, waiting fo the remaining bytes"; - return (undef, undef); # data may be incomplete (very unlikely if not impossible ...) - } - Modbus_ParseObj($logHash, $registers, $type.$adr); - Log3 $name, 5, "$name: ParseFrames done, reply to fCode $fCode, " . scalar keys (%{$logHash->{gotReadings}}) . " readings"; - return (undef, $registers); - } elsif ($fCode == 5) { # reply to write single coil - my $rlen = length ($data); - if ($rlen < 4) { - Log3 $name, 5, "$name: ParseFrames expects 4, got $rlen, waiting fo the remaining bytes"; - return (undef, undef); # data may be incomplete (very unlikely if not impossible ...) - } - my ($radr, $coilCode) = unpack ('nH4', $data); # todo: radr gegen adr testen? - Log3 $name, 5, "$name: ParseFrames reply to fCode $fCode, coilCode $coilCode"; - Modbus_ParseObj($logHash, ($coilCode eq "ff00" ? 1 : 0), $type.$radr, 1); - Log3 $name, 5, "$name: ParseFrames done, reply to fCode 6, " . scalar keys (%{$logHash->{gotReadings}}) . " readings"; - return (undef, $coilCode); - } elsif ($fCode == 6) { # reply to write single (holding) register - my $rlen = length ($data); - if ($rlen < 4) { - Log3 $name, 5, "$name: ParseFrames expects 4, got $rlen, waiting fo the remaining bytes"; - return (undef, undef); # data may be incomplete (very unlikely if not impossible ...) - } - my ($radr, $register) = unpack ('na*', $data); # todo: radr gegen adr testen? - Modbus_ParseObj($logHash, $register, $type.$radr); - Log3 $name, 5, "$name: ParseFrames done, reply to fCode 6, " . scalar keys (%{$logHash->{gotReadings}}) . " readings"; - return (undef, $register); - } elsif ($fCode == 15 || $fCode == 16) { # reply to write multiple coils / holding registers - my $rlen = length ($data); - if ($rlen < 4) { - Log3 $name, 5, "$name: ParseFrames expects 4, got $rlen, waiting fo the remaining bytes"; - return (undef, undef); # data may be incomplete (very unlikely if not impossible ...) - } - my ($radr, $quantity) = unpack ('nn', $data); # todo: radr gegen adr testen? - Log3 $name, 5, "$name: ParseFrames done, reply to fcode 16, $quantity objects written"; - return (undef, $quantity); - } elsif ($fCode >= 128) { # error + my $values = $data; # real value part of data (typically after a length byte) - will be overwritten + my $actualLen = length ($data); # actually read length of data part (registers / coils / ...) for comparison + my $headerLen = 4; # expected len for some fcodes, will be overwritten for others + my $parseAdr = $adr; # default, can be overwritten if adr is contained in reply + my $quantity = 0; # only used for coils / di and fcode 1 or 2. If 0 parseObj ignores it + + if ($fCode == 1 || $fCode == 2) { # read coils / discrete inputs, pdu: bytes, coils + ($headerLen, $values) = unpack ('Ca*', $data); + $actualLen = length ($values); + $quantity = $reqLen; # num of coils + } elsif ($fCode == 3 || $fCode == 4) { # read holding/input registers, pdu: bytes, registers + ($headerLen, $values) = unpack ('Ca*', $data); + $actualLen = length ($values); + } elsif ($fCode == 5) { # write single coil, pdu: adr, coil (FF00) + ($parseAdr, $values) = unpack ('nH4', $data); + $values = ($values eq "ff00" ? 1 : 0); + $quantity = 1; + # length of $data should be 4 + } elsif ($fCode == 6) { # write single (holding) register, pdu: adr, register + ($parseAdr, $values) = unpack ('na*', $data); + # length of $data should be 4 + } elsif ($fCode == 15 || $fCode == 16) { # write mult coils/hold. regis, pdu: adr, quantity + ($parseAdr, $quantity) = unpack ('nn', $data); + # quantity is only used for coils -> ignored for fcode 16 later + # length of $data should be 4 + } elsif ($fCode < 128) { # other function code + Log3 $name, 3, "$name: ParseFrames: function code $fCode not implemented"; + return "function code $fCode not implemented"; + } + + if ($fCode >= 128) { # error my $hexdata = unpack ("H*", $data); my $hexFCode = unpack ("H*", pack("C", $fCode)); - my $err = $errCodes{$hexdata}; + my $errCode = $errCodes{$hexdata}; Log3 $name, 5, "$name: ParseFrames got error code $hexFCode / $hexdata" . - ($err ? ", $err" : ""); - return ("got exception code $hexFCode / $hexdata" . - ($err ? ", $err" : ""), undef); - } else { # other function code - Log3 $name, 3, "$name: ParseFrames: function code $fCode not implemented"; - return ("function code $fCode not implemented", undef); + ($errCode ? ", $errCode" : ""); + return "device replied with exception code $hexFCode / $hexdata" . ($errCode ? ", $errCode" : ""); + } else { + if ($headerLen > $actualLen) { + Log3 $name, 5, "$name: ParseFrames: wait for more data ($actualLen / $headerLen)"; + return undef; + } + return "ParseFrames got wrong Checksum (expect $eCRC, got $CRC)" if ($eCRC != $CRC); + Log3 $name, 4, "$name: ParseFrames got fcode $fCode from $devAdr, tid $tid, ". + "values " . unpack ('H*', $values) . " request was for $type.$parseAdr ($ioHash->{REQUEST}{READING})". + ", len $reqLen for module $logHash->{NAME}"; + if ($fCode < 15) { + # nothing to parse after reply to 15 / 16 + Modbus_ParseObj($logHash, $values, $type.$parseAdr, $quantity); + Log3 $name, 5, "$name: ParseFrames got " . scalar keys (%{$logHash->{gotReadings}}) . " readings from ParseObj"; + } else { + Log3 $name, 5, "$name: reply to fcode 15 and 16 does not contain values"; + } + return 1; } - return ("internal module error in ParseFrames", undef); } + ##################################### # End of BUSY # called with physical device hash @@ -740,10 +803,8 @@ Modbus_EndBUSY($) ##################################### # Called from the global loop, when the select for hash->{FD} reports data -# hash is hash of physical device or logical -# depending on PROTOCOL TCP / RTU -sub -Modbus_Read($) +# hash is hash of logical device ( = physical device for TCP) +sub Modbus_Read($) { # physical layer function - read to common physical buffers ... my $hash = shift; @@ -758,18 +819,50 @@ Modbus_Read($) $hash->{helper}{buffer} .= $buf; $hash->{helper}{lrecv} = $now; # physical side - my ($err, $framedata) = Modbus_ParseFrames($hash); - if ($framedata || $err) { - Modbus_EndBUSY ($hash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig - #Modbus_Statistics($hash, "BusyTime", gettimeofday() - $hash->{helper}{lsend}); - # Busy ist vorbei (hier oder bei Timeout), start in HandleSendQueue, lsend + my $code = Modbus_ParseFrames($hash); + if ($code) { + if ($code ne "1") { + Log3 $name, 5, "$name: ParseFrames returned error: $code" + } delete $hash->{TIMEOUTS}; - + Modbus_EndBUSY ($hash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig RemoveInternalTimer ("queue:$name"); Modbus_HandleSendQueue ("direct:$name"); # don't wait for next regular handle queue slot } } + +########################### +# open connection +sub Modbus_Open($;$) +{ + my ($hash, $reopen) = @_; + my $name = $hash->{NAME}; + my $now = gettimeofday(); + $reopen = 0 if (!$reopen); + + if ($hash->{BUSY_OPENDEV}) { # still waiting for callback to last open + if ($hash->{LASTOPEN} && $now > $hash->{LASTOPEN} + (AttrVal($name, "timeout", 2)*2) + && $now > $hash->{LASTOPEN} + 15) { + Log3 $name, 5, "$name: _Open - still waiting for open callback, timeout is over twice - this should never happen"; + Log3 $name, 5, "$name: _Open - stop waiting and reset the flag."; + $hash->{BUSY_OPENDEV} = 0; + } else { + Log3 $name, 5, "$name: _Open - still waiting for open callback"; + return; + } + } + Log3 $name, 3, "$name: trying to open connection to $hash->{DeviceName}" if (!$reopen); + $hash->{IODev} = $hash if ($hash->{DEST}); # for TCP Log-Module himself is IODev (this is removed during CloseDev) + $hash->{RAWBUFFER} = ""; + $hash->{BUSY} = 0; + $hash->{BUSY_OPENDEV} = 1; + $hash->{LASTOPEN} = $now; + $hash->{nextOpenDelay} = AttrVal($name, "nextOpenDelay", 60); + DevIo_OpenDev($hash, $reopen, 0, \&Modbus_OpenCB); +} + + # ready fn for physical and tcp ##################################### sub @@ -778,30 +871,22 @@ Modbus_Ready($) my ($hash) = @_; my $name = $hash->{NAME}; - my $now = gettimeofday(); - - if ($hash->{BUSY_OPENDEV}) { # still waiting for callback to last open - if ($hash->{LASTOPEN} && $now > $hash->{LASTOPEN} + (AttrVal($name, "timeout", 2)*2) - && $now > $hash->{LASTOPEN} + 15) { - Log3 $name, 5, "$name: _Ready - still waiting for open callback, timeout is over twice - this should never happen"; - Log3 $name, 5, "$name: _Ready - stop waiting and reset the flag."; - $hash->{BUSY_OPENDEV} = 0; - } else { + if($hash->{STATE} eq "disconnected") { + if (AttrVal($name, "disable", undef)) { + Log3 $name, 3, "$name: _Reconnect: $name attr disabled was set - don't try to reconnect"; + DevIo_CloseDev($hash); + $hash->{RAWBUFFER} = ""; + $hash->{BUSY} = 0; return; } - } - - if($hash->{STATE} eq "disconnected") { - $hash->{BUSY_OPENDEV} = 1; - $hash->{nextOpenDelay} = AttrVal($name, "nextOpenDelay", 60); - $hash->{LASTOPEN} = $now; - return DevIo_OpenDev($hash, 1, 0, \&Modbus_OpenCB); + Modbus_Open($hash, 1); # reopen + return; # a return value only triggers direct read for windows - next round in main loop will select for available data } # This is relevant for windows/USB only my $po = $hash->{USBDev}; if ($po) { my ($BlockingFlags, $InBytes, $OutBytes, $ErrorFlags) = $po->status; - return ($InBytes>0); + return ($InBytes>0); # tell fhem.pl to read when we return } } @@ -826,23 +911,62 @@ sub Modbus_CRC($) { } +##################################### +sub Modbus_LRC($) { + use bytes; + my $frame = shift; + my $lrc = 0; + my $chr; + for my $i (0..bytes::length($frame)-1) { + $chr = ord(bytes::substr($frame, $i, 1)); + $lrc = ($lrc + $chr) & 0xff; + } + return (0xff - $lrc) +1; +} + + +################################################### +# reconnect TCP connection (called from ControlSet) +sub Modbus_Reconnect($) +{ + my ($hash) = @_; + my $name = $hash->{NAME}; + my $dest = $hash->{DEST}; + + if (!$dest) { + Log3 $name, 3, "$name: not using a TCP connection, reconnect not supported"; + return; + } + + if (AttrVal($name, "disable", undef)) { + Log3 $name, 3, "$name: _Reconnect: $name attr disabled was set - don't try to reconnect"; + DevIo_CloseDev($hash); + $hash->{RAWBUFFER} = ""; + $hash->{BUSY} = 0; + return; + } + + DevIo_CloseDev($hash); + delete $hash->{NEXT_OPEN}; + delete $hash->{DevIoJustClosed}; + Modbus_Open($hash); +} + + ####################################### -sub -Modbus_CountTimeouts($) +sub Modbus_CountTimeouts($) { my ($hash) = @_; my $name = $hash->{NAME}; if ($hash->{DEST}) { - # modbus TCP + # modbus TCP/RTU/ASCII over TCP if ($hash->{TIMEOUTS}) { $hash->{TIMEOUTS}++; - if (AttrVal($name, "maxTimeoutsToReconnect", 0) && $hash->{TIMEOUTS} >= AttrVal($name, "maxTimeoutsToReconnect", 3)) { - Log3 $name, 3, "$name: $hash->{TIMEOUTS} successive timeouts, trying to reconnect"; - DevIo_CloseDev($hash); - $hash->{RAWBUFFER} = ""; - $hash->{BUSY} = 0; - DevIo_OpenDev($hash, 0, 0); + my $max = AttrVal($name, "maxTimeoutsToReconnect", 0); + if ($max && $hash->{TIMEOUTS} >= $max) { + Log3 $name, 3, "$name: $hash->{TIMEOUTS} successive timeouts, setting state to disconnected"; + DevIo_Disconnected($hash); } } else { $hash->{TIMEOUTS} = 1; @@ -862,7 +986,7 @@ Modbus_TimeoutSend($) my $ioHash = $defs{$name}; Log3 $name, 4, "$name: timeout waiting for $ioHash->{REQUEST}{FCODE} " . - "from $ioHash->{REQUEST}{DEVICE}{MODBUSID}, " . + "from $ioHash->{REQUEST}{MODBUSID}, " . "Request was $ioHash->{REQUESTHEX}, " . "last Buffer: $ioHash->{RAWBUFFER}"; @@ -878,13 +1002,12 @@ Modbus_TimeoutSend($) ####################################### # prüfe delays vor dem Senden -sub -Modbus_CheckDelay($$$$$) +sub Modbus_CheckDelay($$$$$) { my ($ioHash, $force, $title, $delay, $last) = @_; return if (!$delay); my $name = $ioHash->{NAME}; - my $lNam = $ioHash->{REQUEST}{DEVICE}{NAME}; + my $lNam = $ioHash->{REQUEST}{DEVHASH}{NAME}; my $now = gettimeofday(); my $t2 = $last + $delay; my $rest = $t2 - $now; @@ -908,8 +1031,7 @@ Modbus_CheckDelay($$$$$) # Aufruf aus InternalTimer mit "queue:$name" # oder direkt mit "direkt:$name # wobei name das physical device ist -sub -Modbus_HandleSendQueue($;$) +sub Modbus_HandleSendQueue($;$) { my (undef,$name) = split(':', shift); my $force = shift; @@ -950,9 +1072,13 @@ Modbus_HandleSendQueue($;$) my $len = $ioHash->{REQUEST}{LEN}; my $tid = $ioHash->{REQUEST}{TID}; my $adr = $ioHash->{REQUEST}{ADR}; - + my $reqId = $ioHash->{REQUEST}{MODBUSID}; + my $proto = $ioHash->{REQUEST}{PROTOCOL}; + my $type = $ioHash->{REQUEST}{TYPE}; + my $fCode = $ioHash->{REQUEST}{FCODE}; + if($bstring ne "") { # if something to send - do so - my $logHash = $ioHash->{REQUEST}{DEVICE}; + my $logHash = $ioHash->{REQUEST}{DEVHASH}; #Log3 $name, 5, "$name: checks delays: lrecv = $ioHash->{helper}{lrecv}"; # check defined delays @@ -965,7 +1091,7 @@ Modbus_HandleSendQueue($;$) #Log3 $name, 5, "$name: check clientSwitchDelay ..."; my $clSwDelay = AttrVal($name, "clientSwitchDelay", 0); if ($clSwDelay && $ioHash->{helper}{lid} - && $logHash->{MODBUSID} != $ioHash->{helper}{lid}) { + && $reqId != $ioHash->{helper}{lid}) { return if (Modbus_CheckDelay($ioHash, $force, "clientSwitchDelay", $clSwDelay, @@ -990,15 +1116,14 @@ Modbus_HandleSendQueue($;$) $ioHash->{BUSY} = 1; # modbus bus is busy until response is received $ioHash->{helper}{buffer} = ""; # clear Buffer for reception - Log3 $name, 4, "$name: sends $ioHash->{REQUESTHEX} " . - "(fcode $ioHash->{REQUEST}{FCODE} to $ioHash->{REQUEST}{DEVICE}{MODBUSID}, tid $tid for $reading ($adr), len $len)"; + Log3 $name, 4, "$name: HandleSendQueue sends fc $fCode to $reqId, tid $tid for $reading ($type$adr), len $len)"; DevIo_SimpleWrite($ioHash, $bstring, 0); $now = gettimeofday(); $ioHash->{helper}{lsend} = $now; # remember when last send to this bus $logHash->{helper}{lsend} = $now; # remember when last send to this device - $ioHash->{helper}{lid} = $logHash->{MODBUSID}; # device id we talked to + $ioHash->{helper}{lid} = $reqId; # device id we talked to Modbus_Statistics($ioHash, "Requests", 1); Modbus_Profiler($ioHash, "Wait"); @@ -1029,13 +1154,16 @@ ModbusLD_Initialize($ ) { my ($modHash) = @_; - $modHash->{DefFn} = "ModbusLD_Define"; # functions are provided by the Modbus base module - $modHash->{UndefFn} = "ModbusLD_Undef"; - $modHash->{ReadFn} = "Modbus_Read"; - $modHash->{ReadyFn} = "Modbus_Ready"; - $modHash->{AttrFn} = "ModbusLD_Attr"; - $modHash->{SetFn} = "ModbusLD_Set"; - $modHash->{GetFn} = "ModbusLD_Get"; + $modHash->{DefFn} = "ModbusLD_Define"; # functions are provided by the Modbus base module + $modHash->{UndefFn} = "ModbusLD_Undef"; + $modHash->{ReadFn} = "Modbus_Read"; + $modHash->{ReadyFn} = "Modbus_Ready"; + $modHash->{AttrFn} = "ModbusLD_Attr"; + $modHash->{SetFn} = "ModbusLD_Set"; + $modHash->{GetFn} = "ModbusLD_Get"; + $modHash->{NotifyFn} = "ModbusLD_Notify"; + + $modHash->{AttrList}= "do_not_notify:1,0 " . "IODev " . # fhem.pl macht dann $hash->{IODev} = $defs{$ioname} @@ -1044,6 +1172,8 @@ ModbusLD_Initialize($ ) "nextOpenDelay " . "disable:0,1 " . "maxTimeoutsToReconnect " . # for Modbus over TCP/IP only + + "(get|set)([0-9]+)request([0-9]+) " . $readingFnAttributes; @@ -1056,6 +1186,7 @@ ModbusLD_Initialize($ ) "obj-[cdih][0-9]+-map " . "obj-[cdih][0-9]+-set " . "obj-[cdih][0-9]+-setexpr " . + "obj-[cdih][0-9]+-textArg " . "obj-[cdih][0-9]+-revRegs " . "obj-[cdih][0-9]+-bswapRegs " . "obj-[cdih][0-9]+-len " . @@ -1064,7 +1195,7 @@ ModbusLD_Initialize($ ) "obj-[cdih][0-9]+-encode " . "obj-[cdih][0-9]+-expr " . "obj-[cdih][0-9]+-format " . - "obj-[cdih][0-9]+-showget " . + "obj-[cdih][0-9]+-showGet " . "obj-[cdih][0-9]+-poll " . "obj-[cdih][0-9]+-polldelay "; @@ -1087,6 +1218,11 @@ ModbusLD_Initialize($ ) "dev-timing-timeout " . "dev-timing-sendDelay " . "dev-timing-commDelay "; + + $modHash->{ScanAttrList} = + "scan-[cdih]-range " . + "scan-modbusid-range "; + } @@ -1097,31 +1233,35 @@ ModbusLD_SetIODev($) my ($hash) = @_; my $name = $hash->{NAME}; my $ioName = AttrVal($name, "IODev", ""); - my $ioDev; + my $ioHash; if ($ioName) { - if ($defs{$ioName}) { # gibt es den Geräte hash zum IODev Attribut? - $ioDev = $defs{$ioName}; - Log3 $name, 5, "$name: SetIODev is using $ioName given in attribute"; + # handle IODev Attribute + if ($defs{$ioName}) { # gibt es den Geräte-Hash zum IODev Attribut? + $ioHash = $defs{$ioName}; } else { - Log3 $name, 3, "$name: SetIODev can't use $ioName - device does not exist"; + Log3 $name, 3, "$name: SetIODev can't use $ioName from IODev attribute - device does not exist"; } } - if (!$ioDev) { + if (!$ioHash) { + # search for usable physical Modbus device for my $p (sort { $defs{$b}{NR} <=> $defs{$a}{NR} } keys %defs) { if ( $defs{$p}{TYPE} eq "Modbus") { - $ioDev = $defs{$p}; + $ioHash = $defs{$p}; + $attr{$name}{IODev} = $ioHash->{NAME}; # set IODev attribute last; } } } - if ($ioDev) { - $attr{$name}{IODev} = $ioDev->{NAME}; # set IODev attribute - $hash->{IODev} = $ioDev; # set internal to io device hash - Log3 $name, 5, "$name: SetIODev $ioDev->{NAME}"; - } else { + if (!$ioHash) { + # still nothing found -> give up for now Log3 $name, 3, "$name: SetIODev found no physical modbus device"; + return undef; } - return $ioDev; + + $hash->{IODev} = $ioHash; # point internal IODev to io device hash + $hash->{IODev}{defptr}{$hash->{MODBUSID}} = $hash; # register this logical device for given id at io hash + Log3 $name, 5, "$name: SetIODev is using $ioHash->{NAME}"; + return $ioHash; } @@ -1135,7 +1275,7 @@ sub ModbusLD_SetTimer($;$) my $now = gettimeofday(); $start = 0 if (!$start); - if ($hash->{INTERVAL}) { + if ($hash->{INTERVAL} && $hash->{INTERVAL} > 0) { if ($hash->{TimeAlign}) { my $count = int(($now - $hash->{TimeAlign} + $start) / $hash->{INTERVAL}); my $curCycle = $hash->{TimeAlign} + $count * $hash->{INTERVAL}; @@ -1149,7 +1289,7 @@ sub ModbusLD_SetTimer($;$) RemoveInternalTimer("update:$name"); InternalTimer($nextTrigger, "ModbusLD_GetUpdate", "update:$name", 0); Log3 $name, 4, "$name: update timer modified: will call GetUpdate in " . - sprintf ("%.1f", $nextTrigger - $now) . " seconds at $hash->{TRIGGERTIME_FMT}"; + sprintf ("%.1f", $nextTrigger - $now) . " seconds at $hash->{TRIGGERTIME_FMT} - Interval $hash->{INTERVAL}"; } else { $hash->{TRIGGERTIME} = 0; $hash->{TRIGGERTIME_FMT} = ""; @@ -1158,8 +1298,7 @@ sub ModbusLD_SetTimer($;$) ##################################### -sub -Modbus_OpenCB($$) +sub Modbus_OpenCB($$) { my ($hash, $msg) = @_; my $name = $hash->{NAME}; @@ -1167,6 +1306,7 @@ Modbus_OpenCB($$) Log3 $name, 5, "$name: Open callback: $msg" if ($msg); } delete $hash->{BUSY_OPENDEV}; + delete $hash->{TIMEOUTS} if ($hash->{FD}); } @@ -1177,11 +1317,22 @@ ModbusLD_Define($$) my ($hash, $def) = @_; my @a = split("[ \t]+", $def); my ($name, $module, $id, $interval, $dest, $proto) = @a; - my $ret = ""; return "wrong syntax: define $module [id] [interval] [host:port] [RTU|ASCII|TCP]" if(@a < 2); + if ($proto) { + $proto = uc($proto); + return "wrong syntax: define $module [id] [interval] [host:port] [RTU|ASCII|TCP]" + if ($proto !~ /RTU|ASCII|TCP/); + } else { + if ($dest && uc($dest) =~ /RTU|ASCII|TCP/) { + # no host but protocol given + $proto = uc($dest); + $dest = ""; + } + } + # for TCP $id is an optional Unit ID that is ignored by most devices # but some gateways may use it to select the device to forward to. @@ -1189,46 +1340,48 @@ ModbusLD_Define($$) $interval = 0 if (!defined($interval)); $proto = "RTU" if (!defined($proto)); $dest = "" if (!defined($dest)); + + return "Interval has to be numeric" if ($interval !~ /[0-9.]+/); + $hash->{NOTIFYDEV} = "global"; # NotifyFn nur aufrufen wenn global events (INITIALIZED) + # löschen ist möglich mit $hash->{NOTIFYDEV} = ","; + + $hash->{ModuleVersion} = $Modbus_Version; $hash->{MODBUSID} = $id; $hash->{INTERVAL} = $interval; - $hash->{PROTOCOL} = $proto; - $hash->{DEST} = $dest; + $hash->{PROTOCOL} = $proto; $hash->{'.getList'} = ""; $hash->{'.setList'} = ""; $hash->{".updateSetGet"} = 1; - # debug - Log3 $name, 3, "$name: define with destination $dest, protocol $proto"; + #Log3 $name, 3, "$name: _define called with destination $dest, protocol $proto"; - if ($dest) { # Modbus TCP mit IP Adresse angegeben. + my $msg; + if ($dest) { # Modbus über TCP mit IP Adresse angegeben (TCP oder auch RTU/ASCII über TCP) + $dest .= ":502" if ($dest !~ /.*:[0-9]/); # add default port if no port specified + $hash->{DEST} = $dest; $hash->{IODev} = $hash; # Modul ist selbst IODev $hash->{defptr}{$id} = $hash; # ID verweist zurück auf eigenes Modul $hash->{DeviceName} = $dest; # needed by DevIo to get Device, Port, Speed etc. - $hash->{RAWBUFFER} = ""; - $hash->{BUSY} = 0; - $hash->{BUSY_OPENDEV} = 1; - $hash->{nextOpenDelay} = AttrVal($name, "nextOpenDelay", 60); - $ret = DevIo_OpenDev($hash, 0, 0, \&Modbus_OpenCB); + $hash->{STATE} = "disconnected"; # initial value + # Modbus_Open($hash); # now done in NotifyFn after INIT } else { + # logical device that uses a physical Modbus device + $hash->{DEST} = ""; if (ModbusLD_SetIODev($hash)) { # physical device found and asigned as IODev - $hash->{IODev}{defptr}{$id} = $hash; # register this logical device for given modbus id - $dest = $hash->{IODev}{NAME}; # display name of IODev in Log + $dest = "Device $hash->{IODev}{NAME}"; # display name of IODev in Log $hash->{STATE} = "opened"; } else { $hash->{STATE} = "no IO Dev"; - $ret = "no physical modbus device defined"; + $msg = "but no physical modbus device defined"; $dest = "none"; } } - - ModbusLD_SetTimer($hash, 2); # first Update in 2 seconds or aligned - $hash->{ModuleVersion} = $Modbus_Version; Log3 $name, 3, "$name: defined with id $id, interval $interval, destination $dest, protocol $proto" . - ($ret ? ": " . $ret : ""); + ($msg ? $msg : ""); - return $ret; + return; } @@ -1252,14 +1405,13 @@ ModbusLD_Attr(@) return "Invalid Expression $aVal"; } } elsif ($aName eq "IODev") { # defptr housekeeping - my $id = $hash->{MODBUSID}; - if ($defs{$aVal}) { # gibt es den Geräte hash zum IODev Attribut? - $hash->{IODev}{defptr}{$id} = $defs{$aVal}; # register logical device + my $ioHash = $defs{$aVal}; + if ($ioHash && $ioHash->{TYPE} eq "MODBUS") { # gibt es den Geräte hash zum IODev Attribut? + $ioHash->{defptr}{$hash->{MODBUSID}} = $ioHash; # register logical device Log3 $name, 5, "$name: Attr IODev - using $aVal"; } else { - Log3 $name, 3, "$name: Attr IODev can't use $aVal - device does not exist"; - } - + Log3 $name, 5, "$name: Attr IODev can't use $aVal - device does not exist (yet?) or is not a physical Modbus Device"; + } } elsif ($aName eq 'alignTime') { my ($alErr, $alHr, $alMin, $alSec, undef) = GetTimeSpec($aVal); return "Invalid Format $aVal in $aName : $alErr" if ($alErr); @@ -1272,6 +1424,25 @@ ModbusLD_Attr(@) addToDevAttrList($name, $aName); $hash->{".updateSetGet"} = 1; } + + if ($aName eq 'disable') { + if ($hash->{DEST}) { + # take action only for Modbus TCP + if ($cmd eq "set" && $aVal) { + Log3 $name, 5, "$name: disable attribute set on a Modbus TCP connection" . + ($hash->{FD} ? ", closing connection" : ""); + DevIo_CloseDev($hash); + $hash->{RAWBUFFER} = ""; + $hash->{BUSY} = 0; + } elsif ($cmd eq "del" || ($cmd eq "set" && !$aVal)) { + Log3 $name, 5, "$name: disable attribute removed on a Modbus TCP connection"; + DevIo_CloseDev($hash); + delete $hash->{NEXT_OPEN}; + delete $hash->{DevIoJustClosed}; + Modbus_Open($hash); + } + } + } return undef; } @@ -1282,7 +1453,8 @@ ModbusLD_Undef($$) { my ($hash, $arg) = @_; my $name = $hash->{NAME}; - DevIo_CloseDev($hash) if ($hash->{IODev} == $hash); + + DevIo_CloseDev($hash) if ($hash->{DEST}); # logical Device over TCP - no underlying physical Device RemoveInternalTimer ("update:$name"); RemoveInternalTimer ("timeout:$name"); RemoveInternalTimer ("queue:$name"); @@ -1349,13 +1521,25 @@ ModbusLD_UpdateGetSetList($) ##################################### # Get Funktion für logische Geräte / Module -sub -ModbusLD_Get($@) +sub ModbusLD_Get($@) { my ($hash, @a) = @_; return "\"get $a[0]\" needs at least one argument" if(@a < 2); my $name = $hash->{NAME}; my $getName = $a[1]; + + my $objCombi; + if ($getName ne "?") { + $objCombi = ModbusLD_ObjKey($hash, $getName); + Log3 $name, 5, "$name: Get: key for $getName = $objCombi"; + } + + if (!$objCombi) { + ModbusLD_UpdateGetSetList($hash) if ($hash->{".updateSetGet"}); + Log3 $name, 5, "$name: Get: $getName not found, return list $hash->{'.getList'}" + if ($getName ne "?"); + return "Unknown argument $a[1], choose one of $hash->{'.getList'}"; + } if (AttrVal($name, "disable", undef)) { Log3 $name, 5, "$name: get called with $getName but device is disabled" @@ -1365,42 +1549,23 @@ ModbusLD_Get($@) my $ioHash = ModbusLD_GetIOHash($hash); return undef if (!$ioHash); - - my $objCombi; - if ($getName ne "?") { - $objCombi = ModbusLD_ObjKey($hash, $getName); - Log3 $name, 5, "$name: Get: key for $getName = $objCombi"; - } + + my ($err, $result); + Log3 $name, 5, "$name: Get: Requesting $getName ($objCombi)"; - if ($objCombi) { - my ($err, $result); - #my $type = substr($objCombi, 0, 1); - #my $adr = substr($objCombi, 1); - Log3 $name, 5, "$name: Get: Requesting $getName ($objCombi)"; - - if ($ioHash->{BUSY}) { - Log3 $name, 5, "$name: Get: Queue is stil busy - taking over the read with ReadAnswer"; - # Answer for last function code has not yet arrived + if ($ioHash->{BUSY}) { # Answer for last function code has not yet arrived + Log3 $name, 5, "$name: Get: Queue is stil busy - taking over the read with ReadAnswer"; - ($err, $result) = ModbusLD_ReadAnswer($hash); - Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig - } - - ModbusLD_Send($hash, $objCombi, "read", 0, 1); # add at beginning of queue and force send / sleep if necessary - ($err, $result) = ModbusLD_ReadAnswer($hash, $getName); - Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig - - return $err if ($err); - return $result; - } else { - ModbusLD_UpdateGetSetList($hash) if ($hash->{".updateSetGet"}); - Log3 $name, 5, "$name: Get: $getName not found, return list $hash->{'.getList'}" - if ($getName ne "?"); - return "Unknown argument $a[1], choose one of $hash->{'.getList'}"; + ModbusLD_ReadAnswer($hash); # finish last read and wait for the result before next request + Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig } - RemoveInternalTimer ("queue:$name"); - Modbus_HandleSendQueue ("direct:$name"); # don't wait for next regular handle queue slot - return; + + ModbusLD_Send($hash, $objCombi, "read", 0, 1); # add at beginning of queue and force send / sleep if necessary + ($err, $result) = ModbusLD_ReadAnswer($hash, $getName); + Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig + + return $err if ($err); + return $result; } @@ -1413,37 +1578,39 @@ sub ModbusLD_ControlSet($$$) my $name = $hash->{NAME}; if ($setName eq 'interval') { - if (!$setVal) { - Log3 $name, 3, "$name: no interval (sec) specified in set, continuing with $hash->{INTERVAL} (sec)"; - return "No Interval specified"; + if (!$setVal || $setVal !~ /[0-9.]+/) { + Log3 $name, 3, "$name: no valid interval (secs) specified in set, continuing with $hash->{INTERVAL} (sec)"; + return "No valid Interval specified"; } else { $hash->{INTERVAL} = $setVal; Log3 $name, 3, "$name: timer interval changed to $hash->{INTERVAL} seconds"; ModbusLD_SetTimer($hash); return "0"; } + } elsif ($setName eq 'reread') { ModbusLD_GetUpdate("reread:$name"); return "0"; + } elsif ($setName eq 'reconnect') { - if (!$hash->{DEST} || $hash->{IODev} != $hash) { - Log3 $name, 3, "$name: not a TCP connection, reconnect not supported"; + if (!$hash->{DEST}) { + Log3 $name, 3, "$name: not using a TCP connection, reconnect not supported"; return "0"; } - DevIo_CloseDev($hash); - $hash->{RAWBUFFER} = ""; - $hash->{BUSY} = 0; - DevIo_OpenDev($hash, 0, 0); + Modbus_Reconnect($hash); return "0"; + } elsif ($setName eq 'stop') { RemoveInternalTimer("update:$name"); $hash->{TRIGGERTIME} = 0; $hash->{TRIGGERTIME_FMT} = ""; Log3 $name, 3, "$name: internal interval timer stopped"; return "0"; + } elsif ($setName eq 'start') { ModbusLD_SetTimer($hash); return "0"; + } return undef; # no control set identified - continue with other sets } @@ -1459,22 +1626,13 @@ ModbusLD_Set($@) my $setName = $a[1]; my $setVal = $a[2]; my $rawVal = ""; - - my $ioHash = ModbusLD_GetIOHash($hash); - return undef if (!$ioHash); - if (AttrVal($name, "enableControlSet", undef)) { # spezielle Sets freigeschaltet? + if (AttrVal($name, "enableControlSet", undef)) { # spezielle Sets freigeschaltet? my $error = ModbusLD_ControlSet($hash, $setName, $setVal); - return undef if (defined($error) && $error eq "0"); # control set found and done. - return $error if ($error); # error + return undef if (defined($error) && $error eq "0"); # control set found and done. + return $error if ($error); # error # continue if function returned undef } - - if (AttrVal($name, "disable", undef)) { - Log3 $name, 4, "$name: set called with $setName but device is disabled" - if ($setName ne "?"); - return undef; - } my $objCombi; if ($setName ne "?") { @@ -1482,48 +1640,66 @@ ModbusLD_Set($@) Log3 $name, 5, "$name: Set: key for $setName = $objCombi"; } - if ($objCombi) { - my $type = substr($objCombi, 0, 1); - #my $adr = substr($objCombi, 1); - my ($err,$result); - if (!defined($setVal)) { - Log3 $name, 3, "$name: No Value given to set $setName"; - return "No Value given to set $setName"; - } - Log3 $name, 5, "$name: Set: found option $setName ($objCombi), setVal = $setVal"; + if (!$objCombi) { + ModbusLD_UpdateGetSetList($hash) if ($hash->{".updateSetGet"}); + Log3 $name, 5, "$name: Set: $setName not found, return list $hash->{'.setList'}" + if ($setName ne "?"); + return "Unknown argument $a[1], choose one of $hash->{'.setList'}"; + } - if ($ioHash->{BUSY}) { - Log3 $name, 5, "$name: Set: Queue still busy - taking over the read with ReadAnswer"; - # Answer for last function code has not yet arrived + if (AttrVal($name, "disable", undef)) { + Log3 $name, 4, "$name: set called with $setName but device is disabled" + if ($setName ne "?"); + return undef; + } - ($err, $result) = ModbusLD_ReadAnswer($hash); - Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig - } - my $map = ModbusLD_ObjInfo($hash, $objCombi, "map", "defMap"); - my $setmin = ModbusLD_ObjInfo($hash, $objCombi, "min", "", ""); # default to "" - my $setmax = ModbusLD_ObjInfo($hash, $objCombi, "max", "", ""); # default to "" - my $setexpr = ModbusLD_ObjInfo($hash, $objCombi, "setexpr"); - - my $fCode = ModbusLD_DevInfo($hash, $type, "write", $defaultFCode{$type}{write}); + my $ioHash = ModbusLD_GetIOHash($hash); # get or reconstruct ioHash. reconnecton is done in Queue handling if necessary + return undef if (!$ioHash); + + my $type = substr($objCombi, 0, 1); + my ($err,$result); + + # todo: noarg checking? + if (!defined($setVal)) { + Log3 $name, 3, "$name: No Value given to set $setName"; + return "No Value given to set $setName"; + } + Log3 $name, 5, "$name: Set: found option $setName ($objCombi), setVal = $setVal"; - if ($map) { # 1. Schritt: Map prüfen - my $rm = $map; - $rm =~ s/([^ ,\$]+):([^ ,\$]+),? ?/$2 $1 /g; # reverse map string erzeugen - my %rmap = split (' ', $rm); # reverse hash aus dem reverse string - if (defined($rmap{$setVal})) { # reverse map Eintrag für das Reading und den Wert definiert - $rawVal = $rmap{$setVal}; - Log3 $name, 5, "$name: Set: found $setVal in map and converted to $rawVal"; - } else { # Wert nicht in der Map - Log3 $name, 3, "$name: Set: Value $setVal did not match defined map"; - return "Set Value $setVal did not match defined map"; - } - } else { # wenn keine map, dann wenigstens sicherstellen, dass numerisch. - if ($setVal !~ /^-?\d+\.?\d*$/) { - Log3 $name, 3, "$name: Set: Value $setVal is not numeric"; - return "Set Value $setVal is not numeric"; - } - $rawVal = $setVal; + if ($ioHash->{BUSY}) { + Log3 $name, 5, "$name: Set: Queue still busy - taking over the read with ReadAnswer"; + # Answer for last function code has not yet arrived + ModbusLD_ReadAnswer($hash); # finish last read and wait for the result before next request + Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig + } + my $map = ModbusLD_ObjInfo($hash, $objCombi, "map", "defMap"); + my $setmin = ModbusLD_ObjInfo($hash, $objCombi, "min", "", ""); # default to "" + my $setmax = ModbusLD_ObjInfo($hash, $objCombi, "max", "", ""); # default to "" + my $setexpr = ModbusLD_ObjInfo($hash, $objCombi, "setexpr"); + my $textArg = ModbusLD_ObjInfo($hash, $objCombi, "textArg"); + my $unpack = ModbusLD_ObjInfo($hash, $objCombi, "unpack", "defUnpack", "n"); + my $revRegs = ModbusLD_ObjInfo($hash, $objCombi, "revRegs", "defRevRegs"); + my $swpRegs = ModbusLD_ObjInfo($hash, $objCombi, "bswapRegs", "defBswapRegs"); + my $len = ModbusLD_ObjInfo($hash, $objCombi, "len", "defLen", 1); + + my $fCode = ModbusLD_DevInfo($hash, $type, "write", $defaultFCode{$type}{write}); + + if ($map) { # 1. Schritt: Map prüfen + my $rm = $map; + $rm =~ s/([^ ,\$]+):([^ ,\$]+),? ?/$2 $1 /g; # reverse map string erzeugen + my %rmap = split (' ', $rm); # reverse hash aus dem reverse string + if (defined($rmap{$setVal})) { # reverse map Eintrag für das Reading und den Wert definiert + $rawVal = $rmap{$setVal}; + Log3 $name, 5, "$name: Set: found $setVal in map and converted to $rawVal"; + } else { # Wert nicht in der Map + Log3 $name, 3, "$name: Set: Value $setVal did not match defined map"; + return "Set Value $setVal did not match defined map"; } + } else { + $rawVal = $setVal; + } + + if ($rawVal =~ /^-?\d+\.?\d*$/) { if ($setmin ne "") { # 2. Schritt: falls definiert Min- und Max-Werte prüfen Log3 $name, 5, "$name: Set: checking value $rawVal against min $setmin"; return "value $rawVal is smaller than min ($setmin)" if ($rawVal < $setmin); @@ -1532,45 +1708,49 @@ ModbusLD_Set($@) Log3 $name, 5, "$name: Set: checking value $rawVal against max $setmax"; return "value $rawVal is bigger than max ($setmax)" if ($rawVal > $setmax); } - if ($setexpr) { # 3. Schritt: Konvertiere mit setexpr falls definiert - my $val = $rawVal; - $rawVal = eval($setexpr); - Log3 $name, 5, "$name: Set: converted Value $val to $rawVal using expr $setexpr"; + } else { + if (!$textArg) { + Log3 $name, 3, "$name: Set: Value $rawVal is not numeric and textArg not specified"; + return "Set Value $rawVal is not numeric and textArg not specified"; } + } + + if ($setexpr) { # 3. Schritt: Konvertiere mit setexpr falls definiert + my $val = $rawVal; + $rawVal = eval($setexpr); + Log3 $name, 5, "$name: Set: converted Value $val to $rawVal using expr $setexpr"; + } - ModbusLD_Send($hash, $objCombi, "write", $rawVal, 1); # add at beginning and force send / sleep if necessary + my $packedVal = pack ($unpack, $rawVal); + Log3 $name, 5, "$name: set packed " . unpack ('H*', $rawVal) . " with $unpack to " . unpack ('H*', $packedVal); + $packedVal = Modbus_RevRegs($hash, $packedVal, $len) if ($revRegs && $len > 1); + $packedVal = Modbus_SwpRegs($hash, $packedVal, $len) if ($swpRegs); + + ModbusLD_Send($hash, $objCombi, "write", $packedVal, 1); # add at beginning and force send / sleep if necessary + ($err, $result) = ModbusLD_ReadAnswer($hash, $setName); + Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig + return $err if ($err); + + if ($fCode == 15 || $fCode == 16) { + # read after write + Log3 $name, 5, "$name: Set: sending read after write"; + + ModbusLD_Send($hash, $objCombi, "read", 0, 1); # add at beginning and force send / sleep if necessary ($err, $result) = ModbusLD_ReadAnswer($hash, $setName); Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig - - return $err if ($err); - - if ($fCode == 16) { - # read after write - Log3 $name, 5, "$name: Set: sending read after write"; - - ModbusLD_Send($hash, $objCombi, "read", 0, 1); # add at beginning and force send / sleep if necessary - ($err, $result) = ModbusLD_ReadAnswer($hash, $setName); - Modbus_EndBUSY ($ioHash); # set BUSY to 0, delete REQUEST, clear Buffer, do Profilig - - return $err if ($err); - } - return undef; # no return code if no error - } else { # undefiniertes Set - ModbusLD_UpdateGetSetList($hash) if ($hash->{".updateSetGet"}); - Log3 $name, 5, "$name: Set: $setName not found, return list $hash->{'.setList'}" - if ($setName ne "?"); - return "Unknown argument $a[1], choose one of $hash->{'.setList'}"; + return "$err (in read after write for FCode 16)" if ($err); } - RemoveInternalTimer ("queue:$name"); - Modbus_HandleSendQueue ("direct:$name"); # don't wait for next regular handle queue slot + return undef; # no return code if no error } -##################################### +############################################### # Called from get / set to get a direct answer # called with logical device hash -sub -ModbusLD_ReadAnswer($;$) +# has to return a value and an error separately +# so set can ignore the value and only return an error +# whereas get needs the value or error +sub ModbusLD_ReadAnswer($;$) { my ($hash, $reading) = @_; my $name = $hash->{NAME}; @@ -1654,19 +1834,22 @@ ModbusLD_ReadAnswer($;$) $now = gettimeofday(); $hash->{helper}{lrecv} = $now; $ioHash->{helper}{lrecv} = $now; - Log3 $name, 5, "ReadAnswer got: " . unpack ("H*", $ioHash->{helper}{buffer}); + Log3 $name, 5, "$name: ReadAnswer got: " . unpack ("H*", $ioHash->{helper}{buffer}); } - my ($err, $framedata) = Modbus_ParseFrames($ioHash); - if ($framedata || $err) { - Log3 $name, 5, "$name: ReadAnswer done" . - ($err ? ", err = $err" : ""); - - if ($reading && defined($hash->{gotReadings}{$reading})) { - return ($err, $hash->{gotReadings}{$reading}); - } else { - return ($err, $framedata); + my $code = Modbus_ParseFrames($ioHash); + if ($code) { + if ($code ne "1") { + Log3 $name, 5, "$name: ReadAnswer: ParseFrames returned error: $code"; + return ($code, undef); } + + Log3 $name, 5, "$name: ReadAnswer done" . ($reading ? ", reading is $reading" : "") . + (defined($hash->{gotReadings}{$reading}) ? ", value: $hash->{gotReadings}{$reading}" : ""); + if ($reading && defined($hash->{gotReadings}{$reading})) { + return (undef, $hash->{gotReadings}{$reading}); # no error + } + return (undef, undef); # no error but also no value } } return ("no Data", undef); @@ -1689,7 +1872,7 @@ ModbusLD_GetUpdate($) { my $now = gettimeofday(); my $ioHash = ModbusLD_GetIOHash($hash); - if ($calltype eq "update") { + if ($calltype eq "update") { ## todo check if interval > min ModbusLD_SetTimer($hash); } @@ -1744,12 +1927,14 @@ ModbusLD_GetUpdate($) { } } } + Log3 $name, 5, "$name: GetUpdate tries to combine read commands"; - my ($obj, $type, $adr, $reading, $len, $span); my ($nextObj, $nextType, $nextAdr, $nextReading, $nextLen, $nextSpan); my $maxLen; $adr = 0; $type = ""; $span = 0; $nextSpan = 0; + + # combine objects in Readlist by increasing the length of a first obejct and removing the second foreach $nextObj (sort keys %readList) { $nextType = substr($nextObj, 0, 1); $nextAdr = substr($nextObj, 1); @@ -1757,27 +1942,27 @@ ModbusLD_GetUpdate($) { $nextLen = ModbusLD_ObjInfo($hash, $nextObj, "len", "defLen", 1); $readList{$nextObj} = $nextLen; if ($obj && $maxLen){ - $nextSpan = ($nextAdr + $nextLen) - $adr; + $nextSpan = ($nextAdr + $nextLen) - $adr; # Combined length with next object if ($nextType eq $type && $nextSpan <= $maxLen && $nextSpan > $span) { - Log3 $name, 5, "$name: GetUpdate combines $reading / $obj ". - "with $nextReading / $nextObj, span = $nextSpan, dropping read for $nextObj"; - delete $readList{$nextObj}; # no individual read for this object, combine with last + Log3 $name, 5, "$name: Combine $reading ($obj) with $nextReading ($nextObj), ". + "span=$nextSpan, max=$maxLen, drop read for $nextObj"; + delete $readList{$nextObj}; # no individual read for this object, combine with last $span = $nextSpan; - $readList{$obj} = $nextSpan; + $readList{$obj} = $nextSpan; # increase the length to include following object next; # don't change current object variables } else { - Log3 $name, 5, "$name: GetUpdate cannot combine $reading / $obj ". - "with $nextReading / $nextObj, span would be $nextSpan"; + Log3 $name, 5, "$name: No Combine $reading / $obj with $nextReading / $nextObj, ". + "span $nextSpan > max $maxLen"; $nextSpan = 0; } } ($obj, $type, $adr, $reading, $len, $span) = ($nextObj, $nextType, $nextAdr, $nextReading, $nextLen, $nextSpan); $maxLen = ModbusLD_DevInfo($hash, $type, "combine", 1); - Log3 $name, 5, "$name: GetUpdate: combine for $type is $maxLen"; + # Log3 $name, 5, "$name: GetUpdate: combine for $type is $maxLen"; } Modbus_Profiler($ioHash, "Idle"); while (my ($objCombi, $span) = each %readList) { - ModbusLD_Send($hash, $objCombi, "read", 0, 0, $readList{$objCombi}); + ModbusLD_Send($hash, $objCombi, "read", 0, 0, $readList{$objCombi}); # readList contains length / span } } @@ -1788,16 +1973,73 @@ ModbusLD_GetUpdate($) { # with log dev hash to get the # physical io device hash -sub -ModbusLD_GetIOHash($){ +sub ModbusLD_GetIOHash($){ my $hash = shift; my $name = $hash->{NAME}; # name of logical device - my $ioHash = ($hash->{TYPE} eq "MODBUS" ? $hash : $hash->{IODev}); - if (!$ioHash) { - Log3 $name, 3, "$name: no IODev found for $hash->{NAME}"; - return undef; + my $ioHash; + + if ($hash->{TYPE} eq "MODBUS") { + # physical Device + return $hash; + } else { + # logical Device + if ($hash->{DEST}) { + # Modbus TCP/RTU/ASCII über TCP, physical hash = logical hash + return $hash; + } else { + # logical device needs pointer to physical device (IODev) + return $hash->{IODev} if ($hash->{IODev}); + # recreate $hash->{IODev} and defptr registration using attr or usable physical Modbus device + if (ModbusLD_SetIODev($hash)) { + return $hash->{IODev}; + } + Log3 $name, 3, "$name: no IODev attribute or matching physical Modbus-device found for $hash->{NAME}"; + } } - return $ioHash; + return undef; +} + + +##################################### +# called from send and parse +# reverse order of word registers +sub Modbus_RevRegs($$$) { + my ($hash, $buffer, $len) = @_; # hash only needed for logging + my $name = $hash->{NAME}; # name of device for logging + + Log3 $name, 5, "$name: RevRegs: reversing order of up to $len registers"; + my $work = substr($buffer, 0, $len * 2); # the first 2*len bytes of buffer + my $rest = substr($buffer, $len * 2); # everything after len + + my $new = ""; + while ($work) { + $new = substr($work, 0, 2) . $new; # prepend first two bytes of work to new + $work = substr($work, 2); # remove first word from work + } + Log3 $name, 5, "$name: RevRegs: string before is " . unpack ("H*", $buffer); + $buffer = $new . $rest; + Log3 $name, 5, "$name: RevRegs: string after is " . unpack ("H*", $buffer); + return $buffer; +} + + +##################################### +# called from send and parse +# reverse byte order in word registers +sub Modbus_SwpRegs($$$) { + my ($hash, $buffer, $len) = @_; # hash only needed for logging + my $name = $hash->{NAME}; # name of device for logging + + Log3 $name, 5, "$name: SwpRegs: reversing byte order of up to $len registers"; + my $rest = substr($buffer, $len * 2); # everything after len + my $nval = ""; + for (my $i = 0; $i < $len; $i++) { + $nval = $nval . substr($buffer,$i*2 + 1,1) . substr($buffer,$i*2,1); + }; + Log3 $name, 5, "$name: SwpRegs: string before is " . unpack ("H*", $buffer); + $buffer = $nval . $rest; + Log3 $name, 5, "$name: SwpRegs: string after is " . unpack ("H*", $buffer); + return $buffer; } @@ -1805,8 +2047,7 @@ ModbusLD_GetIOHash($){ ##################################### # called from logical device fuctions # with log dev hash -sub -ModbusLD_Send($$$;$$$){ +sub ModbusLD_Send($$$;$$$){ my ($hash, $objCombi, $op, $v1, $force, $span) = @_; # $hash : the logival Device hash # $objCombi : type+adr @@ -1815,30 +2056,28 @@ ModbusLD_Send($$$;$$$){ # $force : put in front of queue and don't reschedule but wait if necessary my $name = $hash->{NAME}; # name of logical device - my $modHash = $modules{$hash->{TYPE}}; # hash of logical module - my $devInfo = $modHash->{deviceInfo}; my $devId = $hash->{MODBUSID}; + my $proto = $hash->{PROTOCOL}; my $ioHash = ModbusLD_GetIOHash($hash); my $type = substr($objCombi, 0, 1); my $adr = substr($objCombi, 1); my $reading = ModbusLD_ObjInfo($hash, $objCombi, "reading"); my $len = ModbusLD_ObjInfo($hash, $objCombi, "len", "defLen", 1); - my $unpack = ModbusLD_ObjInfo($hash, $objCombi, "unpack", "defUnpack", "n"); return if (!$ioHash); my $ioName = $ioHash->{NAME}; my $qlen = ($ioHash->{QUEUE} ? scalar(@{$ioHash->{QUEUE}}) : 0); - Log3 $name, 4, "$name: Send called with $type $adr len $len / span " . + Log3 $name, 4, "$name: Send called with $type$adr, len $len / span " . ($span ? $span : "-") . " to id $devId, queue has $qlen requests"; - $len = $span if ($span); # span given as parameter + $len = $span if ($span); # span given as parameter (only for combined read requests from GetUpdate) if ($qlen && AttrVal($ioName, "dropQueueDoubles", 0)) { Log3 $name, 5, "$name: Send is checking if request is already in queue ($qlen requests)"; foreach my $elem (@{$ioHash->{QUEUE}}) { - Log3 $name, 5, "$name: check against queue element $elem->{TYPE} $elem->{ADR} len $elem->{LEN} to id $elem->{DEVICE}{MODBUSID}"; + Log3 $name, 5, "$name: is it $elem->{TYPE} $elem->{ADR} len $elem->{LEN} to id $elem->{MODBUSID}?"; if($elem->{ADR} == $adr && $elem->{TYPE} eq $type - && $elem->{LEN} == $len && $elem->{DEVICE}{MODBUSID} eq $devId) { + && $elem->{LEN} == $len && $elem->{MODBUSID} eq $devId) { Log3 $name, 4, "$name: request already in queue - dropping"; return; } @@ -1850,56 +2089,60 @@ ModbusLD_Send($$$;$$$){ Log3 $name, 3, "$name: Send did not find fCode for $op type $type (obj $reading)"; return; } - my $data = ""; - if ($fCode == 1 || $fCode == 2) { # read coils / discrete inputs, pdu format: StartAdr, Len - $data = pack ('nn', $adr, $len); - } elsif ($fCode == 3 || $fCode == 4) { # read holding / input registers, pdu format: StartAdr, Len - $data = pack ('nn', $adr, $len); - } elsif ($fCode == 5) { # function code "write single coil", pdu format: StartAdr, Value - $data = pack ('nH4', $adr, ($v1 ? "FF00" : "0000")); - } elsif ($fCode == 6) { # function code "write single register", pdu format: StartAdr, Value - $data = pack ('n'.$unpack, $adr, $v1); - } elsif ($fCode == 15) { # function code "write multiple coils", pdu format: StartAdr, NumOfCoils, ByteCount, Values - $data = pack ('nnCC', $adr, int($len/8)+1, $len, $v1); - } elsif ($fCode == 16) { # function code "write multiple registers", pdu format: StartAdr, NumOfRegisters, ByteCount, Values - $data = pack ('nnC'.$unpack, $adr, $len, $len*2, $v1); - } else { - # function code not implemented yet + my $data; + if ($fCode == 1 || $fCode == 2) { # read coils / discrete inputs, pdu: StartAdr, Len (=number of coils) + $data = pack ('nn', $adr, $len); + } elsif ($fCode == 3 || $fCode == 4) { # read holding/input registers, pdu: StartAdr, Len (=number of regs) + $data = pack ('nn', $adr, $len); + } elsif ($fCode == 5) { # write single coil, pdu: StartAdr, Value (1-bit as FF00) + $data = pack ('nH4', $adr, ($v1 ? "FF00" : "0000")); + } elsif ($fCode == 6) { # write single register, pdu: StartAdr, Value + $data = pack ('n', $adr) . $v1; + } elsif ($fCode == 15) { # write multiple coils, pdu: StartAdr, NumOfCoils, ByteCount, Values + $data = pack ('nnCC', $adr, int($len/8)+1, $len, $v1); # todo: test / fix + } elsif ($fCode == 16) { # write multiple regs, pdu: StartAdr, NumOfRegs, ByteCount, Values + $data = pack ('nnC', $adr, $len, $len*2) . $v1; + } else { # function code not implemented yet Log3 $name, 3, "$name: Send function code $fCode not yet implemented"; return; } my $pdu = pack ('C', $fCode) . $data; #Log3 $name, 5, "$ioName: Send fcode $fCode for $reading, pdu : " . unpack ('H*', $pdu); - my ($frame, $header, $crc, $dlen); + my $frame; my $tid = 0; + my $packedId = pack ('C', $devId); - if ($hash->{PROTOCOL} eq "RTU") { # frame format: DevID, (fCode, data), CRC - $header = pack ('C', ($devId)); - $crc = pack ('v', Modbus_CRC($header . $pdu)); - $frame = $header.$pdu.$crc; - } elsif ($hash->{PROTOCOL} eq "TCP") { # frame format: tid, 0, len, DevID, (fCode, data) - $tid = int(rand(255)); - $dlen = bytes::length($pdu)+1; # length of pdu + devId - $header = pack ('nnnC', ($tid, 0, $dlen, $devId)); - $frame = $header.$pdu; + if ($proto eq "RTU") { # frame format: DevID, (fCode, data), CRC + my $crc = pack ('v', Modbus_CRC($packedId . $pdu)); + $frame = $packedId . $pdu . $crc; + } elsif ($proto eq "ASCII") { # frame format: DevID, (fCode, data), LRC + my $lrc = uc(unpack ('H2', pack ('v', Modbus_LRC($packedId.$pdu)))); + #Log3 $name, 5, "$name: LRC: $lrc"; + $frame = ':' . uc(unpack ('H2', $packedId) . unpack ('H*', $pdu)) . $lrc . "\r\n"; + } elsif ($proto eq "TCP") { # frame format: tid, 0, len, DevID, (fCode, data) + $tid = int(rand(255)); + my $dlen = bytes::length($pdu)+1; # length of pdu + devId + my $header = pack ('nnnC', ($tid, 0, $dlen, $devId)); + $frame = $header.$pdu; #Log3 $name, 5, "$ioName: Send TCP frame tid=$tid, dlen=$dlen, devId=$devId, pdu=" . unpack ('H*', $pdu); } - Log3 $name, 4, "$name: Send queues fcode $fCode for $type $adr ($reading), len / span $len : " . - unpack ('H*', $frame) . " pdu " . unpack ('H*', $pdu) . - ($force ? ", force" : ""); + Log3 $name, 4, "$name: Send queues fc $fCode to $devId, tid $tid for $type$adr ($reading), len/span $len, PDU " . + unpack ('H*', $pdu) . ($force ? ", force" : ""); my %request; $request{FRAME} = $frame; # frame as data string - $request{DEVICE} = $hash; # logical device in charge + $request{DEVHASH} = $hash; # logical device in charge $request{FCODE} = $fCode; # function code $request{TYPE} = $type; # type of object (cdih) $request{ADR} = $adr; # address of object $request{LEN} = $len; # span / number of registers / length of object $request{READING} = $reading; # reading name of the object $request{TID} = $tid; # transaction id for Modbus TCP + $request{PROTOCOL} = $proto; # RTU / ASCII / ... + $request{MODBUSID} = $devId; # ModbusId of the addressed device - coming from logical device hash if(!$qlen) { #Log3 $name, 5, "$name: Send is creating new queue"; @@ -1907,7 +2150,7 @@ ModbusLD_Send($$$;$$$){ } else { #Log3 $name, 5, "$name: Send initial queue length is $qlen"; if ($qlen > AttrVal($name, "queueMax", 100)) { - Log3 $name, 3, "$name: Send queue too long, dropping request"; + Log3 $name, 3, "$name: Send queue too long ($qlen), dropping new request"; } else { if ($force) { unshift (@{$ioHash->{QUEUE}}, \%request); # an den Anfang @@ -1923,6 +2166,9 @@ ModbusLD_Send($$$;$$$){ 1; =pod +=item device +=item summary base module for devices with Modbus Interface +=item summary_DE Basismodul für Geräte mit Modbus-Interface =begin html