FHEM/fhem-mirror
2
0
Fork 0
mirror of https://github.com/fhem/fhem-mirror.git synced 2025-04-19 06:36:04 +00:00
Code Issues Releases Wiki Activity

98_Modbus.pm: fix scanning, some warnings and optimize logging

Browse Source 
git-svn-id: https://svn.fhem.de/fhem/trunk@23625 2b470e98-0d58-463d-a4d8-8e2adae1ed80
This commit is contained in:
StefanStrobel 2021-01-27 15:18:16 +00:00
parent 1310600d2c
commit 23525e281f
1 changed files with 157 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

203
fhem/FHEM/98_Modbus.pm
View File

@ -23,6 +23,10 @@
# #
# ToDo / Ideas # ToDo / Ideas
# Log levels aufräumen (4-5) got incomplete frame etc.
# obj-xxx-group g-p
# details on requested / combined objects when timeout (store in debug hash key)
#
# limit combine?!! # limit combine?!!
# verify that nextOpenDelay is integer and >= 1 # verify that nextOpenDelay is integer and >= 1
# set active results in error when tcp is already open # set active results in error when tcp is already open
@ -203,7 +207,7 @@ use Exporter ('import');
our @EXPORT_OK = qw(); our @EXPORT_OK = qw();
our %EXPORT_TAGS = (all => [@EXPORT_OK]); our %EXPORT_TAGS = (all => [@EXPORT_OK]);
BEGIN { BEGIN { # functions / variables needed from package main
GP_Import( qw( GP_Import( qw(
CommandAttr CommandAttr
CommandDeleteAttr CommandDeleteAttr
@ -242,6 +246,7 @@ BEGIN {
DevIo_SimpleRead DevIo_SimpleRead
DevIo_CloseDev DevIo_CloseDev
DevIo_IsOpen DevIo_IsOpen
DevIo_Disconnected
SetExtensions SetExtensions
TcpServer_Open TcpServer_Open
@ -256,6 +261,7 @@ BEGIN {
init_done init_done
)); ));
# function to be visible im package main as Modbus_Name
GP_Export( qw( GP_Export( qw(
Initialize Initialize
)); ));
@ -271,7 +277,7 @@ BEGIN {
}; };
my $Module_Version = '4.3.11 - 2.1.2021'; my $Module_Version = '4.3.15 - 23.1.2021';
my $PhysAttrs = join (' ', my $PhysAttrs = join (' ',
'queueDelay', 'queueDelay',
@ -470,7 +476,9 @@ my %attrDefaults = (
); );
########################################################### ###########################################################
# _initialize für das physische Basismodul # _initialize for the physical io device,
# exported as Modbus_Initialize
# called when the module is lodaded by Fhem
sub Initialize { sub Initialize {
my $modHash = shift; my $modHash = shift;
@ -840,7 +848,7 @@ sub AttrLDFn {
} }
elsif ($aName eq 'verbose') { elsif ($aName eq 'verbose') {
if ($hash->{TCPServer} && $hash->{FD}) { if ($hash->{TCPServer} && $hash->{FD}) {
Log3 $name, 4, "$name: delete verbose level in connection subdevices"; Log3 $name, 5, "$name: delete verbose level in connection subdevices";
foreach my $conn (keys %{$hash->{CONNECTHASH}}) { foreach my $conn (keys %{$hash->{CONNECTHASH}}) {
my $chash = $hash->{CONNECTHASH}{$conn}; my $chash = $hash->{CONNECTHASH}{$conn};
delete $attr{$chash->{NAME}}{verbose}; delete $attr{$chash->{NAME}}{verbose};
@ -973,7 +981,7 @@ sub GetLDFn {
my $objCombi = ObjKey($hash, $getName); my $objCombi = ObjKey($hash, $getName);
my $async = AttrVal($name, "nonPrioritizedGet", 0); my $async = AttrVal($name, "nonPrioritizedGet", 0);
return "\"get $name\" needs at least one argument" if (!$getName); return "\"get $name\" needs at least one argument" if (!$getName);
Log3 $name, 5, "$name: get called with $getName " . ($objCombi ? "($objCombi)" : '') if ($getName ne '?'); Log3 $name, 4, "$name: get called with $getName " . ($objCombi ? "($objCombi)" : '') if ($getName ne '?');
if (!$objCombi) { if (!$objCombi) {
UpdateGetSetList($hash) if ($hash->{'.updateSetGet'}); UpdateGetSetList($hash) if ($hash->{'.updateSetGet'});
@ -1068,7 +1076,7 @@ sub SetLDFn {
my $objCombi = ObjKey($hash, $setName); my $objCombi = ObjKey($hash, $setName);
Log3 $name, 5, "$name: set called with $setName " . ($objCombi ? "($objCombi) " : ' ') . Log3 $name, 4, "$name: set called with $setName " . ($objCombi ? "($objCombi) " : ' ') .
(defined($setVal) ? "setVal = $setVal" :'') if ($setName ne '?'); (defined($setVal) ? "setVal = $setVal" :'') if ($setName ne '?');
if (!$objCombi) { if (!$objCombi) {
@ -1410,6 +1418,8 @@ sub ScanObjects {
delete $hash->{scanOEnd}; delete $hash->{scanOEnd};
delete $hash->{scanOType}; delete $hash->{scanOType};
delete $hash->{scanOLen}; delete $hash->{scanOLen};
Log3 $name, 4, "$name: ScanObjects called from " . FhemCaller() . " ends at " .
($hash->{scanOType} // '') . ($hash->{scanOAdr} //'');
return; # end return; # end
} }
$hash->{scanOAdr}++; $hash->{scanOAdr}++;
@ -1417,8 +1427,10 @@ sub ScanObjects {
else { else {
$hash->{scanOAdr} = $hash->{scanOStart}; $hash->{scanOAdr} = $hash->{scanOStart};
} }
DoRequest($hash, {TYPE => $hash->{scanOType}, ADR => $hash->{scanOAdr}, OPERATION => 'scanobj', LEN => $hash->{scanOLen}, DBGINFO => 'scan objs'}); Log3 $name, 4, "$name: ScanObjects called from " . FhemCaller() . " will now try " .
#DoRequest ($hash, $hash->{scanOType}.$hash->{scanOAdr}, 'scanobj', 0, 0, $hash->{scanOLen}, 'scan'); ($hash->{scanOType} // '') . ($hash->{scanOAdr} //'');
DoRequest($hash, {TYPE => $hash->{scanOType}, ADR => $hash->{scanOAdr},
OPERATION => 'scanobj', LEN => $hash->{scanOLen}, DBGINFO => 'scan objs'});
InternalTimer($now+$scanDelay, \&Modbus::ScanObjects, "scan:$name", 0); InternalTimer($now+$scanDelay, \&Modbus::ScanObjects, "scan:$name", 0);
return; return;
} }
@ -1454,6 +1466,8 @@ sub ScanIds {
delete $hash->{scanOAdr}; delete $hash->{scanOAdr};
delete $hash->{scanOLen}; delete $hash->{scanOLen};
delete $hash->{scanOType}; delete $hash->{scanOType};
Log3 $name, 4, "$name: ScanId called from " . FhemCaller() . " will ends with id " .
(delete $hash->{scanId} // '') . ' ' . ($hash->{scanOType} // '') . ($hash->{scanOAdr} //'');
return; # end return; # end
} }
$hash->{scanId}++; $hash->{scanId}++;
@ -1461,8 +1475,10 @@ sub ScanIds {
else { else {
$hash->{scanId} = $hash->{scanIdStart}; $hash->{scanId} = $hash->{scanIdStart};
} }
DoRequest($hash, {TYPE => $hash->{scanOType}, ADR => $hash->{scanOAdr}, OPERATION => 'scanid'.$hash->{scanId}, LEN => $hash->{scanOLen}, DBGINFO => 'scan ids'}); Log3 $name, 4, "$name: ScanId called from " . FhemCaller() . " will now try id " .
#DoRequest ($hash, $hash->{scanOType}.$hash->{scanOAdr}, 'scanid'.$hash->{scanId}, 0, 0, $hash->{scanOLen}, 'scan ids'); ($hash->{scanId} // '') . ' ' . ($hash->{scanOType} // '') . ($hash->{scanOAdr} //'');
DoRequest($hash, {TYPE => $hash->{scanOType}, ADR => $hash->{scanOAdr},
OPERATION => 'scanid'.$hash->{scanId}, LEN => $hash->{scanOLen}, DBGINFO => 'scan ids'});
InternalTimer($now+$scanDelay, \&Modbus::ScanIds, "scan:$name", 0); InternalTimer($now+$scanDelay, \&Modbus::ScanIds, "scan:$name", 0);
return; return;
} }
@ -1626,7 +1642,7 @@ sub DoOpen {
#Log3 $name, 5, "$name: Open nextOpenDelay = $delay2 "; #Log3 $name, 5, "$name: Open nextOpenDelay = $delay2 ";
my $lastOp = $hash->{LASTOPEN}; # set when OpenDev is really called and cleared in DoClose my $lastOp = $hash->{LASTOPEN}; # set when OpenDev is really called and cleared in DoClose
Log3 $name, 5, "$name: open called from $caller, busyOpenDev " . Log3 $name, 5, "$name: open called from $caller, busyOpenDev " .
($hash->{BUSY_OPENDEV} // 0) . ($nextOp ? ' NEXT_OPEN ' . FmtTimeMs($nextOp) : '');# if (!$ready); ($hash->{BUSY_OPENDEV} // 0) . ($nextOp ? ' NEXT_OPEN ' . FmtTimeMs($nextOp) : '') if (!$ready);
if ($hash->{BUSY_OPENDEV}) { # still waiting for callback to last open if ($hash->{BUSY_OPENDEV}) { # still waiting for callback to last open
return if (!$lastOp || $now < $lastOp + ($timeOt * 2) || $now < $lastOp + 15); return if (!$lastOp || $now < $lastOp + ($timeOt * 2) || $now < $lastOp + 15);
Log3 $name, 3, "$name: open - still waiting for open callback, timeout is over twice - this should never happen"; Log3 $name, 3, "$name: open - still waiting for open callback, timeout is over twice - this should never happen";
@ -1644,10 +1660,10 @@ sub DoOpen {
} }
if ($lastOp && $now < ($lastOp + $delay2)) { # ignore too many open requests within nextOpenDelay2 if ($lastOp && $now < ($lastOp + $delay2)) { # ignore too many open requests within nextOpenDelay2
Log3 $name, 5, "$name: successive open ignored, last open was " . Log3 $name, 5, "$name: successive open ignored, last open was " .
sprintf('%3.3f', ($now - $lastOp)) . ' secs ago at ' . FmtTimeMs($lastOp) . " but should be $delay2";# if (!$ready); sprintf('%3.3f', ($now - $lastOp)) . ' secs ago at ' . FmtTimeMs($lastOp) . " but should be $delay2" if (!$ready);
return; return;
} }
Log3 $name, 4, "$name: open trying to open connection to $hash->{DeviceName}";# if (!$ready); Log3 $name, 4, "$name: open trying to open connection to $hash->{DeviceName}" if (!$ready);
delete $hash->{NEXT_OPEN}; # already handled above delete $hash->{NEXT_OPEN}; # already handled above
delete $hash->{DevIoJustClosed} if ($delay2); # allow direct opening without further delay delete $hash->{DevIoJustClosed} if ($delay2); # allow direct opening without further delay
$hash->{IODev} = $hash if ($hash->{TCPConn}); # point back to self $hash->{IODev} = $hash if ($hash->{TCPConn}); # point back to self
@ -1778,8 +1794,6 @@ sub ReadyFn {
} }
############################################################################ ############################################################################
# Called from the global loop, when the select for hash->{FD} reports data # Called from the global loop, when the select for hash->{FD} reports data
# hash is hash of the physical device ( = logical device for TCP) # hash is hash of the physical device ( = logical device for TCP)
@ -1893,7 +1907,7 @@ sub ReadFn {
HandleGaps ($hash); # check timing / frameGap and remove old buffer if necessary HandleGaps ($hash); # check timing / frameGap and remove old buffer if necessary
$hash->{READ}{BUFFER} .= $buf; # now add new data to buffer $hash->{READ}{BUFFER} .= $buf; # now add new data to buffer
$hash->{REMEMBER}{lrecv} = $now; # rember time for physical side $hash->{REMEMBER}{lrecv} = $now; # rember time for physical side
Log3 $name, 5, "$name: read buffer: " . ShowBuffer($hash); Log3 $name, 5, "$name: readFn buffer: " . ShowBuffer($hash);
delete $hash->{FRAME}; # remove old stuff delete $hash->{FRAME}; # remove old stuff
if (!$hash->{MODE} || !$hash->{PROTOCOL}) { # MODE and PROTOCOL keys are taken from logical device in NOTIFY if (!$hash->{MODE} || !$hash->{PROTOCOL}) { # MODE and PROTOCOL keys are taken from logical device in NOTIFY
@ -1974,8 +1988,6 @@ sub ReadAnswer {
# nextTimeout is set when a request is sent. This can be the last getUpdate or the get/set # nextTimeout is set when a request is sent. This can be the last getUpdate or the get/set
$hash->{nextTimeout} = $now + $timeout if (!$hash->{nextTimeout}); # just to be sure, should not happen. $hash->{nextTimeout} = $now + $timeout if (!$hash->{nextTimeout}); # just to be sure, should not happen.
# todo: exit loop with last statement in case of error / timeout and set message variable before
RemoveInternalTimer ("timeout:$name"); # remove timer, timeout is handled in here now RemoveInternalTimer ("timeout:$name"); # remove timer, timeout is handled in here now
Profiler($hash, 'Read'); Profiler($hash, 'Read');
@ -1984,7 +1996,6 @@ sub ReadAnswer {
# get timeout. In case ReadAnswer is called after a delay or to take over an async read, # get timeout. In case ReadAnswer is called after a delay or to take over an async read,
# only wait for remaining time # only wait for remaining time
$timeRest = $hash->{nextTimeout} - gettimeofday(); $timeRest = $hash->{nextTimeout} - gettimeofday();
$timeout = $timeRest if ($timeRest < $timeout); $timeout = $timeRest if ($timeRest < $timeout);
Log3 $name, 5, "$name: ReadAnswer remaining timeout is $timeout"; Log3 $name, 5, "$name: ReadAnswer remaining timeout is $timeout";
@ -2066,24 +2077,25 @@ sub ReadAnswer {
} }
############################################################### ##########################################################################
# check if expected start byte comes later (ASCII or D for RTU) # check if expected start byte comes later (ASCII or D for RTU)
# and skip garbage until this position # and skip garbage until this position
# startByte is always ':'' for ASCII or the Request Id for RTU Responses
# called from parseFrameStart # called from parseFrameStart
sub SkipGarbageCheck { sub SkipGarbageCheck {
my $hash = shift; # io device hash my $hash = shift; # io device hash
my $startByte = shift; # optional byte to look for (: for Modbus ASCII, known ID for RTU) my $startByte = shift; # optional byte to look for (: for Modbus ASCII, known ID for RTU)
my $name = $hash->{NAME}; my $name = $hash->{NAME};
my $skipMode = AttrVal ($name, 'skipGarbage', 0); my $skipMode = AttrVal ($name, 'skipGarbage', 0);
my ($start, $skip); my $start = 0;
return $hash->{READ}{BUFFER} if (!defined($startByte) && !$skipMode); # old behavior if skipMode was not set and no startByte passed return $hash->{READ}{BUFFER} if (!defined($startByte) && !$skipMode); # old behavior if skipMode was not set and no startByte passed
use bytes; use bytes;
if (!$startByte && $hash->{PROTOCOL} eq 'RTU' && $hash->{MODE} eq 'passive') {
if (!$startByte && $hash->{PROTOCOL} eq 'RTU') {
# check for a possible ID of one of the logical devices # check for a possible ID of one of the logical devices
Log3 $name, 4, "$name: SkipGarbageCheck special feature without given id"; Log3 $name, 5, "$name: SkipGarbageCheck special feature without given id";
$start = length($hash->{READ}{BUFFER}); $start = length($hash->{READ}{BUFFER}); # default if no start found -> drop everything
BUFLOOP: BUFLOOP:
for my $pos (0..length($hash->{READ}{BUFFER})-1) { for my $pos (0..length($hash->{READ}{BUFFER})-1) {
my $id = unpack('C', substr($hash->{READ}{BUFFER}, $pos, 1)); my $id = unpack('C', substr($hash->{READ}{BUFFER}, $pos, 1));
@ -2091,19 +2103,19 @@ sub SkipGarbageCheck {
for my $ld (keys %{$hash->{defptr}}) { # for each registered logical device for my $ld (keys %{$hash->{defptr}}) { # for each registered logical device
if ($defs{$ld} && $defs{$ld}{MODBUSID} == $id) { if ($defs{$ld} && $defs{$ld}{MODBUSID} == $id) {
$start = $pos if ($pos < $start); $start = $pos if ($pos < $start);
Log3 $name, 4, "$name: SkipGarbageCheck found potential id $id at $start"; Log3 $name, 4, "$name: SkipGarbageCheck found potential id $id at pos $start";
} }
} }
last BUFLOOP if ($start < length($hash->{READ}{BUFFER})); last BUFLOOP if ($start < length($hash->{READ}{BUFFER})); # exit at first pos found
} }
} else { } elsif ($startByte) {
#Log3 $name, 4, "$name: SkipGarbageCheck looking for start byte " . unpack ('H*', $startByte). #Log3 $name, 4, "$name: SkipGarbageCheck looking for start byte " . unpack ('H*', $startByte).
# " protocol is $hash->{PROTOCOL}, mode is $hash->{MODE}"; # " protocol is $hash->{PROTOCOL}, mode is $hash->{MODE}";
$start = index($hash->{READ}{BUFFER}, $startByte); $start = index($hash->{READ}{BUFFER}, $startByte);
} }
if ($start > 0) { if ($start > 0) {
$skip = substr($hash->{READ}{BUFFER}, 0, $start); my $skip = substr($hash->{READ}{BUFFER}, 0, $start);
$hash->{READ}{BUFFER} = substr($hash->{READ}{BUFFER}, $start); $hash->{READ}{BUFFER} = substr($hash->{READ}{BUFFER}, $start);
Log3 $name, 4, "$name: SkipGarbageCheck skipped $start bytes (" . Log3 $name, 4, "$name: SkipGarbageCheck skipped $start bytes (" .
ShowBuffer($hash, $skip) . ' rest ' . ShowBuffer($hash) . ')'; ShowBuffer($hash, $skip) . ' rest ' . ShowBuffer($hash) . ')';
@ -2124,8 +2136,10 @@ sub ParseFrameStart {
my $expectId; my $expectId;
$expectId = $hash->{REQUEST}{MODBUSID} if ($hash->{REQUEST} && $hash->{REQUEST}{MODBUSID}); $expectId = $hash->{REQUEST}{MODBUSID} if ($hash->{REQUEST} && $hash->{REQUEST}{MODBUSID});
# todo: should be removed in passive mode when the last request was not valid # todo: should be removed in passive mode when the last request was not valid
# todo: somehow slave reception already has a wrong request / id in scanning ...
Log3 $name, 5, "$name: ParseFrameStart called from " . FhemCaller(); Log3 $name, 5, "$name: ParseFrameStart called from " . FhemCaller() .
($expectId ? " protocol $proto expecting id $expectId" : '');
use bytes; use bytes;
if ($proto eq 'RTU') { if ($proto eq 'RTU') {
# Skip for RTU only works when expectId is passed (parsing Modbus responses from a known Id) # Skip for RTU only works when expectId is passed (parsing Modbus responses from a known Id)
@ -2154,10 +2168,10 @@ sub ParseFrameStart {
$hash->{FRAME}{MODBUSID} = $id; $hash->{FRAME}{MODBUSID} = $id;
$hash->{FRAME}{FCODE} = $fCode; $hash->{FRAME}{FCODE} = $fCode;
$hash->{FRAME}{DATA} = $data; $hash->{FRAME}{DATA} = $data;
Log3 $name, 4, "$name: ParseFrameStart ($proto) extracted id $id, fCode $fCode" . Log3 $name, 4, "$name: ParseFrameStart ($proto, $hash->{MODE}) extracted id $id, fCode $fCode" .
($hash->{FRAME}{TID} ? ', tid ' . $hash->{FRAME}{TID} : '') . ($hash->{FRAME}{TID} ? ', tid ' . $hash->{FRAME}{TID} : '') .
($dlen ? ', dlen ' . $dlen : '') . ($dlen ? ', dlen ' . $dlen : '') .
' and data ' . unpack ('H*', $data); ' and potential data ' . unpack ('H*', $data);
return 1; return 1;
} }
@ -2205,7 +2219,7 @@ sub HandleResponse {
} }
} }
else { else {
Log3 $name, 5, "$name: HandleResponse got data but we don't have a request"; Log3 $name, 4, "$name: HandleResponse got data but we don't have a request";
$masterHash = GetLogHash($hash, $frame->{MODBUSID}); $masterHash = GetLogHash($hash, $frame->{MODBUSID});
} }
@ -2222,8 +2236,8 @@ sub HandleResponse {
$response->{ADR} = $request->{ADR}; # prefill so we don't need $request in ParseResponse and it gets shorter $response->{ADR} = $request->{ADR}; # prefill so we don't need $request in ParseResponse and it gets shorter
$response->{LEN} = $request->{LEN}; $response->{LEN} = $request->{LEN};
$response->{OPERATION} = $request->{OPERATION}; # for later call to parseObj $response->{OPERATION} = $request->{OPERATION}; # for later call to parseObj
$response->{MASTERHASH} = $masterHash; $response->{MASTERHASH} = $masterHash if ($masterHash);
$response->{RELAYHASH} = $request->{RELAYHASH}; # not $relayHash! $response->{RELAYHASH} = $request->{RELAYHASH} if ($request->{RELAYHASH}); # not $relayHash!
} # if no request known, we will skip most of the part below } # if no request known, we will skip most of the part below
# parse response and fill response hash # parse response and fill response hash
@ -2299,6 +2313,7 @@ sub ParseResponse {
# adr and len are copied from request # adr and len are copied from request
return if ($dataLength) < 1; return if ($dataLength) < 1;
my ($len, $values) = unpack ('Ca*', $data); # length of values data and values from frame my ($len, $values) = unpack ('Ca*', $data); # length of values data and values from frame
$values = substr($values, 0, $len) if (length($values) > $len);
$response->{VALUES} = $values; $response->{VALUES} = $values;
$response->{TYPE} = ($fCode == 1 ? 'c' : 'd'); # coils or discrete inputs $response->{TYPE} = ($fCode == 1 ? 'c' : 'd'); # coils or discrete inputs
$frame->{PDULEXP} = $len + 2; # 1 Byte fCode + 1 Byte len + len of expected values $frame->{PDULEXP} = $len + 2; # 1 Byte fCode + 1 Byte len + len of expected values
@ -2308,15 +2323,18 @@ sub ParseResponse {
return if ($dataLength) < 1; return if ($dataLength) < 1;
my ($len, $values) = unpack ('Ca*', $data); my ($len, $values) = unpack ('Ca*', $data);
$response->{TYPE} = ($fCode == 3 ? 'h' : 'i'); # holding registers / input registers $response->{TYPE} = ($fCode == 3 ? 'h' : 'i'); # holding registers / input registers
$frame->{PDULEXP} = $len + 2; # 1 Byte fCode + 1 Byte len + len of expected values
if ($fCode == 3 && $masterHash && DevInfo($masterHash, 'h', 'brokenFC3', 0)) { if ($fCode == 3 && $masterHash && DevInfo($masterHash, 'h', 'brokenFC3', 0)) {
# devices that respond with wrong pdu pdu: fCode, adr, registers # devices that respond with wrong pdu pdu: fCode, adr, registers
Log3 $name, 5, "$name: ParseResponse uses fix for broken fcode 3, use len $response->{LEN} from request"; $len = $response->{LEN} * 2;
Log3 $name, 5, "$name: ParseResponse uses fix for broken fcode 3, use len $len from request";
my $adr; my $adr;
($adr, $values) = unpack ('na*', $data); ($adr, $values) = unpack ('na*', $data);
$response->{ADR} = $adr; # adr of registers $response->{ADR} = $adr; # adr of registers
$frame->{PDULEXP} = $response->{LEN} * 2 + 3; # 1 Byte fCode + 2 Byte adr + 2 bytes per register $frame->{PDULEXP} = $response->{LEN} * 2 + 3; # 1 Byte fCode + 2 Byte adr + 2 bytes per register
} else {
$frame->{PDULEXP} = $len + 2; # 1 Byte fCode + 1 Byte len + len of expected values
} }
$values = substr($values, 0, $len) if (length($values) > $len);
$response->{VALUES} = $values; $response->{VALUES} = $values;
} }
elsif ($fCode == 5) { elsif ($fCode == 5) {
@ -2371,7 +2389,7 @@ sub ParseResponse {
my $frameLen = $frame->{PDULEXP} + $PDUOverhead{$hash->{PROTOCOL}}; my $frameLen = $frame->{PDULEXP} + $PDUOverhead{$hash->{PROTOCOL}};
my $readLen = length($hash->{READ}{BUFFER}); my $readLen = length($hash->{READ}{BUFFER});
if ($readLen < $frameLen ) { if ($readLen < $frameLen ) {
Log3 $name, 4, "$name: ParseResponse got incomplete frame. Got $readLen but expecting $frameLen bytes"; Log3 $name, 5, "$name: ParseResponse got incomplete frame. Got $readLen but expecting $frameLen bytes";
return if ($frame->{ERROR}); return if ($frame->{ERROR});
# frame is too small but no error - even checksum is fine! # frame is too small but no error - even checksum is fine!
if (!$masterHash || !DevInfo($masterHash, $response->{TYPE}, 'allowShortResponses', 0)) { if (!$masterHash || !DevInfo($masterHash, $response->{TYPE}, 'allowShortResponses', 0)) {
@ -2380,9 +2398,6 @@ sub ParseResponse {
} }
} }
return 1; # frame complete, go on with other checks / handling / dropping return 1; # frame complete, go on with other checks / handling / dropping
} }
@ -2418,11 +2433,11 @@ sub handleScanResults {
if (AttrVal($name, 'dev-h-defLen', '') ne "$l"); if (AttrVal($name, 'dev-h-defLen', '') ne "$l");
CommandAttr(undef, "$name dev-h-defUnpack a" . $l*2) CommandAttr(undef, "$name dev-h-defUnpack a" . $l*2)
if (AttrVal($name, 'dev-h-defUnpack', '') ne ('a'.$l*2)); if (AttrVal($name, 'dev-h-defUnpack', '') ne ('a'.$l*2));
CommandAttr(undef, "$name dev-h-defExpr ScanFormat(\$hash, \$val)") CommandAttr(undef, "$name dev-h-defExpr Modbus::ScanFormat(\$hash, \$val)")
if (AttrVal($name, 'dev-h-defExpr', '') ne "ScanFormat(\$hash, \$val)"); if (AttrVal($name, 'dev-h-defExpr', '') ne "Modbus::ScanFormat(\$hash, \$val)");
} }
} }
return; return $reading;
} }
@ -2472,7 +2487,7 @@ sub ParseObj {
my $lastAdr = ($valuesLen ? $startAdr + $valuesLen -1 : 0); my $lastAdr = ($valuesLen ? $startAdr + $valuesLen -1 : 0);
my ($unpack, $map, $objLen); my ($unpack, $map, $objLen);
$op = '' if (!$op); $op = '' if (!$op);
Log3 $name, 5, "$name: ParseObj called from " . FhemCaller() . " with data hex " . unpack ('H*', $dataPtr->{VALUES}) . Log3 $name, 4, "$name: ParseObj called from " . FhemCaller() . " with data hex " . unpack ('H*', $dataPtr->{VALUES}) .
", type $type, adr $startAdr" . ($valuesLen ? ", valuesLen $valuesLen" : '') . ($op ? ", op $op" : ''); ", type $type, adr $startAdr" . ($valuesLen ? ", valuesLen $valuesLen" : '') . ($op ? ", op $op" : '');
delete $hash->{gotReadings}; # will be filled later and queried by caller. Used for logging and return value in get-command delete $hash->{gotReadings}; # will be filled later and queried by caller. Used for logging and return value in get-command
@ -2635,9 +2650,13 @@ sub HandleRequest {
# this is forwarded via another io hash on the forwarding master side (not visible here) # this is forwarded via another io hash on the forwarding master side (not visible here)
LogFrame($hash, 'HandleRequest', 4); LogFrame($hash, 'HandleRequest', 4);
if ($frame->{CHECKSUMERROR}) {
$hash->{EXPECT} = 'request'; # wait for another (hopefully valid) request (hash key should already be set to request - only for clarity)
delete $hash->{REQUEST}; # this one was invalid anyway
} else {
$logHash = GetLogHash($hash, $id); # look for Modbus logical slave or relay device (right id) $logHash = GetLogHash($hash, $id); # look for Modbus logical slave or relay device (right id)
if ($logHash && !$frame->{CHECKSUMERROR}) { # other errors might need to create a response answer back to the master if ($logHash) { # other errors might need to create a response answer back to the master
# our id, no cheksum error, we are responsible, logHash is set properly # our id, no cheksum error, we are responsible, logHash is set properly
if ($hash->{MODE} eq 'slave') { if ($hash->{MODE} eq 'slave') {
if (!$request->{ERRCODE} && exists $fcMap{$fCode}{write}) { # supported write fCode request contains data to be parsed and stored if (!$request->{ERRCODE} && exists $fcMap{$fCode}{write}) { # supported write fCode request contains data to be parsed and stored
@ -2658,13 +2677,11 @@ sub HandleRequest {
Log3 $name, 4, "$name: received valid request, now wait for the reponse."; Log3 $name, 4, "$name: received valid request, now wait for the reponse.";
$hash->{EXPECT} = 'response'; # nothing else to do if we are a passive listener $hash->{EXPECT} = 'response'; # nothing else to do if we are a passive listener
} }
} elsif ($frame->{CHECKSUMERROR}) { } else { # none of our ids
$hash->{EXPECT} = 'request'; # wait for another (hopefully valid) request (hash key should already be set to request - only for clarity)
} elsif (!$logHash) { # none of our ids
$hash->{EXPECT} = 'response'; # not our request, parse response that follows $hash->{EXPECT} = 'response'; # not our request, parse response that follows
$msg .= ', frame is not for us'; $msg .= ', frame is not for us';
} }
}
my $text = 'HandleRequest Done' . $msg . ($hash->{FRAME}{ERROR} ? ", error: $hash->{FRAME}{ERROR}" : ''); my $text = 'HandleRequest Done' . $msg . ($hash->{FRAME}{ERROR} ? ", error: $hash->{FRAME}{ERROR}" : '');
LogFrame($hash, $text, 4); LogFrame($hash, $text, 4);
Profiler($hash, 'Idle'); Profiler($hash, 'Idle');
@ -2843,7 +2860,7 @@ sub RelayRequest {
my $relayHash = $request->{RELAYHASH}; # the logical device with MODE relay (that handled the incoming request) my $relayHash = $request->{RELAYHASH}; # the logical device with MODE relay (that handled the incoming request)
# for a relay from TCP to serial this is the connection device hash # for a relay from TCP to serial this is the connection device hash
Log3 $name, 5, "$name: RelayRequest called from " . FhemCaller(); Log3 $name, 4, "$name: RelayRequest called from " . FhemCaller();
my $reIOHash = GetRelayIO($relayHash); # the io device of the relay forward device (relay to) my $reIOHash = GetRelayIO($relayHash); # the io device of the relay forward device (relay to)
my $relayParentHash = ($relayHash->{CHILDOF} ? $relayHash->{CHILDOF} : $relayHash); # switch to parent context if available my $relayParentHash = ($relayHash->{CHILDOF} ? $relayHash->{CHILDOF} : $relayHash); # switch to parent context if available
@ -3075,8 +3092,8 @@ sub QueueRequest {
Log3 $name, 5, "$name: QueueRequest called from " . FhemCaller() . Log3 $name, 5, "$name: QueueRequest called from " . FhemCaller() .
" with $request->{TYPE}$request->{ADR}, qlen $qlen" . " with $request->{TYPE}$request->{ADR}, qlen $qlen" .
(defined ($request->{MASTERHASH}) ? " from master $request->{MASTERHASH}{NAME}" : '' ) . (defined ($request->{MASTERHASH}) && $request->{MASTERHASH}{NAME} ? " from master $request->{MASTERHASH}{NAME}" : '' ) .
(defined ($request->{RELAYHASH}) ? " for relay $request->{RELAYHASH}{NAME}" : '' ) . (defined ($request->{RELAYHASH}) && $request->{RELAYHASH}{NAME} ? " for relay $request->{RELAYHASH}{NAME}" : '' ) .
" through io device $hash->{NAME}"; " through io device $hash->{NAME}";
return if (CheckDisable($hash)); # also returns if there is no io device return if (CheckDisable($hash)); # also returns if there is no io device
@ -3624,11 +3641,9 @@ sub GetUpdate {
my $devInfo = ($hash->{deviceInfo} ? $hash->{deviceInfo} : $modHash->{deviceInfo}); my $devInfo = ($hash->{deviceInfo} ? $hash->{deviceInfo} : $modHash->{deviceInfo});
my $intvl = $hash->{Interval}; my $intvl = $hash->{Interval};
my $now = gettimeofday(); my $now = gettimeofday();
my @ObjList;
my %readList;
Log3 $name, 5, "$name: GetUpdate called from " . FhemCaller(); Log3 $name, 4, "$name: GetUpdate called from " . FhemCaller();
$hash->{'.LastUpdate'} = $now; $hash->{'.LastUpdate'} = $now; # note the we were called - even when not as 'update' and UpdateTimer is not called afterwards
UpdateTimer($hash, \&Modbus::GetUpdate, 'next') if ($calltype eq 'update'); UpdateTimer($hash, \&Modbus::GetUpdate, 'next') if ($calltype eq 'update');
my $msg = CheckDisable($hash); my $msg = CheckDisable($hash);
@ -3639,41 +3654,47 @@ sub GetUpdate {
my $ioHash = GetIOHash($hash); # only needed for profiling, availability id checked in CheckDisable my $ioHash = GetIOHash($hash); # only needed for profiling, availability id checked in CheckDisable
Profiler($ioHash, 'Fhem'); Profiler($ioHash, 'Fhem');
my @ObjList;
foreach my $at (keys %{$attr{$name}}) { foreach my $at (keys %{$attr{$name}}) {
if ($at =~ /^obj-(.*)-reading$/) { if ($at =~ /^obj-(.*)-reading$/) {
push @ObjList, $1 if (!$parseInfo->{$1}); push @ObjList, $1 if (!$parseInfo->{$1});
} }
}; };
Log3 $name, 5, "$name: GetUpdate objects from attributes: " . join (' ', @ObjList); #Log3 $name, 5, "$name: GetUpdate objects from attributes: " . join (' ', @ObjList);
push @ObjList, keys (%{$parseInfo}); push @ObjList, keys (%{$parseInfo});
Log3 $name, 5, "$name: GetUpdate full object list: " . join (' ', sort @ObjList); Log3 $name, 4, "$name: GetUpdate full object list: " . join (' ', sort @ObjList);
# create readList by checking delays and poll settings for ObjList # create readList by checking delays and poll settings for ObjList
my (%readList, %readLen, %readName, %readComb); # list hash + additional info for logging
foreach my $objCombi (sort @ObjList) { foreach my $objCombi (sort @ObjList) {
my $reading = ObjInfo($hash, $objCombi, 'reading'); my $reading = ObjInfo($hash, $objCombi, 'reading');
my $poll = ObjInfo($hash, $objCombi, 'poll'); my $poll = ObjInfo($hash, $objCombi, 'poll');
my $lastRead = $hash->{lastRead}{$objCombi} // 0; my $lastRead = $hash->{lastRead}{$objCombi} // 0;
my $delay = ObjInfo($hash, $objCombi, 'polldelay'); my $delay = ObjInfo($hash, $objCombi, 'polldelay');
Log3 $name, 5, "$name: GetUpdate check $objCombi => $reading, poll = $poll, polldelay = $delay, last = $lastRead"; #Log3 $name, 5, "$name: GetUpdate check $objCombi reading $reading, poll = $poll, polldelay = $delay, last = $lastRead";
if (($poll && $poll ne 'once') || ($poll eq 'once' && !$lastRead)) { # this was wrongly implemented (once should be specified as delay). Keep for backward compatibility if (($poll && $poll ne 'once') || ($poll eq 'once' && !$lastRead)) { # this was wrongly implemented (once should be specified as delay). Keep for backward compatibility
if (!$delay || ($delay && $delay ne 'once') || ($delay eq 'once' && !$lastRead)) { if (!$delay || ($delay && $delay ne 'once') || ($delay eq 'once' && !$lastRead)) {
$delay = 0 if ($delay eq 'once' || !$delay); $delay = 0 if ($delay eq 'once' || !$delay);
$delay = $1 * ($intvl ? $intvl : 1) if ($delay =~ /^x([0-9]+)/); # delay as multiplyer if starts with x $delay = $1 * ($intvl ? $intvl : 1) if ($delay =~ /^x([0-9]+)/); # delay as multiplyer if starts with x
$readList{$objCombi} = 1 if ($now >= $lastRead + $delay); # include it in the list of items to read if ($now >= $lastRead + $delay) {
Log3 $name, 4, "$name: GetUpdate will " . ($readList{$objCombi} ? my $reading = ObjInfo($hash, $objCombi, 'reading');
"request $reading" : "skip $reading, delay not over"); my $len = ObjInfo($hash, $objCombi, 'len');
$readList{$objCombi} = 1; # include it in the list of items to read
$readLen{$objCombi} = $len;
$readName{$objCombi} = $reading;
}
Log3 $name, 5, "$name: GetUpdate will skip $reading, delay not over" if (!$readList{$objCombi});
} }
} }
} }
Log3 $name, 5, "$name: GetUpdate tries to combine read commands"; Log3 $name, 4, "$name: GetUpdate readList before combine = " . join (' ', keys %readList);
my ($obj, $type, $adr, $reading, $len, $span);
my ($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 object and removing the second # combine objects in Readlist by increasing the length of a first object and removing the second
Log3 $name, 4, "$name: GetUpdate readList = " . join (' ', keys %readList); Log3 $name, 5, "$name: GetUpdate tries to combine read commands";
my ($type, $adr, $reading, $len, $span);
my ($nextType, $nextAdr, $nextReading, $nextLen, $nextSpan);
my ($obj, $maxLen);
$adr = 0; $type = ''; $span = 0; $nextSpan = 0;
COMBINELOOP: COMBINELOOP:
foreach my $nextObj (sort compObjKeys keys %readList) { foreach my $nextObj (sort compObjKeys keys %readList) {
$nextType = substr($nextObj, 0, 1); $nextType = substr($nextObj, 0, 1);
@ -3686,6 +3707,8 @@ sub GetUpdate {
if ($nextType eq $type && $nextSpan <= $maxLen && $nextSpan > $span) { if ($nextType eq $type && $nextSpan <= $maxLen && $nextSpan > $span) {
Log3 $name, 5, "$name: GetUpdate combines request for $reading ($obj) with $nextReading ($nextObj), ". Log3 $name, 5, "$name: GetUpdate combines request for $reading ($obj) with $nextReading ($nextObj), ".
"span=$nextSpan, max=$maxLen, drop read for $nextObj"; "span=$nextSpan, max=$maxLen, drop read for $nextObj";
$readComb{$obj} .= ($readComb{$obj} ? ' and ' : "$obj len $readLen{$obj} $readName{$obj} with ")
. "$nextObj len $readLen{$nextObj} $readName{$nextObj}";
delete $readList{$nextObj}; # no individual read for this object, combine with last delete $readList{$nextObj}; # no individual read for this object, combine with last
$span = $nextSpan; $span = $nextSpan;
$readList{$obj} = $nextSpan; # increase the length to include following object $readList{$obj} = $nextSpan; # increase the length to include following object
@ -3701,9 +3724,20 @@ sub GetUpdate {
$maxLen = DevInfo($hash, $type, 'combine', 1); $maxLen = 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";
} }
my $logMsg = '';
foreach my $objCombi (sort compObjKeys keys %readList) {
#Log3 $name, 5, "$name: GetUpdate prepare LogMsg, obj=$objCombi, logMsg=$logMsg";
my $span = $readList{$objCombi};
$logMsg = ($logMsg ? "$logMsg, " : '') . "$objCombi len $span " .
($readComb{$objCombi} ? "(combined $readComb{$objCombi})" : "($readName{$objCombi} len $readLen{$objCombi})");
}
#Log3 $name, 4, "$name: GetUpdate readList = " . join (' ', keys %readList);
Log3 $name, 4, "$name: GetUpdate readList = $logMsg" ;
foreach my $objCombi (sort compObjKeys keys %readList) { foreach my $objCombi (sort compObjKeys keys %readList) {
my $span = $readList{$objCombi}; my $span = $readList{$objCombi};
DoRequest($hash, {TYPE => substr($objCombi, 0, 1), ADR => substr($objCombi, 1), OPERATION => 'read', LEN => $span, DBGINFO => 'getUpdate'}); DoRequest($hash, {TYPE => substr($objCombi, 0, 1), ADR => substr($objCombi, 1), OPERATION => 'read', LEN => $span,
DBGINFO => "getUpdate for " . ($readComb{$objCombi} ? "combined $readComb{$objCombi}" : "$readName{$objCombi} len $readLen{$objCombi}")});
} }
Profiler($ioHash, 'Idle'); Profiler($ioHash, 'Idle');
return; return;
@ -3723,9 +3757,9 @@ sub RequestText {
($request->{LEN} ? ", len $request->{LEN}" : '') . ($request->{LEN} ? ", len $request->{LEN}" : '') .
($request->{VALUES} ? ", value " . unpack('H*', $request->{VALUES}) : '') . ($request->{VALUES} ? ", value " . unpack('H*', $request->{VALUES}) : '') .
(defined($request->{TID}) ? ", tid $request->{TID}" : '') . (defined($request->{TID}) ? ", tid $request->{TID}" : '') .
($request->{DEVHASH} ? ", DEVHASH $request->{DEVHASH}{NAME}" : '') . ($request->{DEVHASH} && $request->{DEVHASH}{NAME} ? ", DEVHASH $request->{DEVHASH}{NAME}" : '') .
($request->{MASTERHASH} ? ", master device $request->{MASTERHASH}{NAME}" : '') . ($request->{MASTERHASH} && $request->{MASTERHASH}{NAME} ? ", master device $request->{MASTERHASH}{NAME}" : '') .
($request->{RELAYHASH} ? ", for relay device $request->{RELAYHASH}{NAME}" : '') . ($request->{RELAYHASH} && $request->{RELAYHASH}{NAME} ? ", for relay device $request->{RELAYHASH}{NAME}" : '') .
($request->{READING} ? ", reading $request->{READING}" : '') . ($request->{READING} ? ", reading $request->{READING}" : '') .
($request->{DBGINFO} ? " ($request->{DBGINFO})" : '') . ($request->{DBGINFO} ? " ($request->{DBGINFO})" : '') .
($request->{QUEUED} ? ', queued ' . sprintf('%.2f', $now - $request->{QUEUED}) . ' secs ago' : '') . ($request->{QUEUED} ? ', queued ' . sprintf('%.2f', $now - $request->{QUEUED}) . ' secs ago' : '') .
@ -3737,13 +3771,12 @@ sub RequestText {
# describe response as string # describe response as string
sub ResponseText { sub ResponseText {
my $response = shift; my $response = shift;
return "response: id $response->{MODBUSID}, " . return "response: " . ($response->{MODBUSID} ? "id $response->{MODBUSID}, " : 'no id') .
($response->{ERRCODE} ? ($response->{FCODE} ? ", fc $response->{FCODE}" : ", no fcode ") .
'fc ' . $response->{FCODE} . " error code $response->{ERRCODE}" : ($response->{ERRCODE} ? ", error code $response->{ERRCODE}" : '') .
"fc $response->{FCODE}") . ($response->{TYPE} && $response->{ADR} ? ", $response->{TYPE} . $response->{ADR}" : '') .
($response->{TYPE} && $response->{ADR} ? ' ' . $response->{TYPE} . $response->{ADR} : '') .
($response->{LEN} ? ", len $response->{LEN}" : '') . ($response->{LEN} ? ", len $response->{LEN}" : '') .
($response->{VALUES} ? ', value ' . unpack('H*', $response->{VALUES}) : '') . ($response->{VALUES} ? ', values ' . unpack('H*', $response->{VALUES}) : '') .
(defined($response->{TID}) ? ", tid $response->{TID}" : ''); (defined($response->{TID}) ? ", tid $response->{TID}" : '');
} }
@ -3791,7 +3824,8 @@ sub DropFrame {
# mode is propagated from logical device so we know if we are master, slave or passive. # mode is propagated from logical device so we know if we are master, slave or passive.
# when we are the forwarding side of a relay, io device would be in mode master # when we are the forwarding side of a relay, io device would be in mode master
if ($hash->{MODE} eq 'passive' && $hash->{FRAME}{CHECKSUMERROR}) { if ($hash->{MODE} ne 'master') {
if ($hash->{FRAME}{CHECKSUMERROR}) {
$drop = substr($hash->{READ}{BUFFER}, 0, 1); $drop = substr($hash->{READ}{BUFFER}, 0, 1);
$rest = substr($hash->{READ}{BUFFER}, 1); $rest = substr($hash->{READ}{BUFFER}, 1);
} }
@ -3802,6 +3836,7 @@ sub DropFrame {
$rest = substr($hash->{READ}{BUFFER}, $frameLen); $rest = substr($hash->{READ}{BUFFER}, $frameLen);
} }
} }
}
Log3 $name, 5, "$name: DropFrame called from " . FhemCaller() . " - drop " . ShowBuffer($hash, $drop) . Log3 $name, 5, "$name: DropFrame called from " . FhemCaller() . " - drop " . ShowBuffer($hash, $drop) .
($rest ? ' rest ' . ShowBuffer($hash, $rest) : ''); ($rest ? ' rest ' . ShowBuffer($hash, $rest) : '');
$hash->{READ}{BUFFER} = $rest; $hash->{READ}{BUFFER} = $rest;
@ -4009,7 +4044,7 @@ sub ResponseTimeout {
if ($hash->{REQUEST}) { if ($hash->{REQUEST}) {
$request = $hash->{REQUEST}; $request = $hash->{REQUEST};
$masterHash = $request->{MASTERHASH}; # REQUEST stored in physical hash by ProcessRequestQueue $masterHash = $request->{MASTERHASH}; # REQUEST stored in physical hash by ProcessRequestQueue
$relayHash = $request->{RELAYHASH} if ($request->{RELAYHASH}); $relayHash = $request->{RELAYHASH};
#Log3 $name, 3, "$name: ResponseTimeout called, master was $masterHash->{NAME}" . #Log3 $name, 3, "$name: ResponseTimeout called, master was $masterHash->{NAME}" .
# ($relayHash ? " for relay $relayHash->{NAME}" : ''); # ($relayHash ? " for relay $relayHash->{NAME}" : '');
} }
@ -4372,7 +4407,7 @@ sub GetLogHash {
my $logName; my $logName;
if ($ioHash->{TCPConn}) { if ($ioHash->{TCPConn}) {
$logHash = $ioHash; # Modbus TCP/RTU/ASCII über TCP, physical hash = logical hash $logHash = $ioHash; # Modbus TCP/RTU/ASCII over TCP, physical hash = logical hash
} }
else { else {
for my $ld (keys %{$ioHash->{defptr}}) { # for each registered logical device for my $ld (keys %{$ioHash->{defptr}}) { # for each registered logical device
@ -4395,7 +4430,7 @@ sub GetLogHash {
} }
$logName = $logHash->{NAME}; # don't refer to parent - we need to focus on the right connection $logName = $logHash->{NAME}; # don't refer to parent - we need to focus on the right connection
if ($logHash->{MODBUSID} != $Id) { if ($logHash->{MODBUSID} != $Id) {
Log3 $name, 3, "$name: GetLogHash called from " . FhemCaller() . ' detected wrong Modbus Id'; Log3 $name, 3, "$name: GetLogHash called from " . FhemCaller() . " detected wrong Modbus Id $Id, expecting $logHash->{MODBUSID}";
return; return;
} }
Log3 $name, 5, "$name: GetLogHash returns hash for device $logName" if (!$ioHash->{TCPConn}); Log3 $name, 5, "$name: GetLogHash returns hash for device $logName" if (!$ioHash->{TCPConn});