mirror of
https://github.com/fhem/fhem-mirror.git
synced 2025-03-04 17:36:39 +00:00
5624 lines
263 KiB
Perl
Executable File
5624 lines
263 KiB
Perl
Executable File
##############################################################################
|
|
# $Id$
|
|
# fhem Modul für Geräte mit Modbus-Interface -
|
|
# Basis für logische Geräte-Module wie zum Beispiel
|
|
# ModbusAttr.pm or ModbusSET.pm
|
|
#
|
|
# This file is part of fhem.
|
|
#
|
|
# Fhem is free software: you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation, either version 2 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# Fhem is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with fhem. If not, see <http://www.gnu.org/licenses/>.
|
|
#
|
|
##############################################################################
|
|
|
|
#
|
|
# ToDo / Ideas
|
|
# verify that nextOpenDelay is integer and >= 1
|
|
# set 'active' results in error when tcp is already open
|
|
# enforce nextOpenDelay even if slave immediately closes
|
|
# after open https://forum.fhem.de/index.php/topic,75638.570.html
|
|
#
|
|
# when define of relay is modified -> close all open TCP server connection devices
|
|
# to force reconnect and get correct parameters
|
|
# debug two tcp relays in parallel on same physical bus
|
|
# (logs shown by mike have strange incoming frames, responses seem to go to wrong device)
|
|
#
|
|
# Allow setting of a _Setup function in the ModbusXY initialize function
|
|
# to be called after init done and not disabled
|
|
# this can then modify the parseInfo Hash depending of a model variant or an offset
|
|
# maybe call whenever startUpdateTime is called as well and _setup has not been called yet?
|
|
# or do it depending on a certain object which is requested during normal getupdate? expr?
|
|
#
|
|
# learn objects in passive mode
|
|
#
|
|
# when an attr is set for a TCP slave or relay, copy attrs to running connection devices
|
|
# at modify from tcp to serial iodev hash key and DeviceName key are kept and wrong
|
|
# min / max checking as slave when we get write fcodes
|
|
#
|
|
# conflicting definitions of attrs for expr etc. when slave uses them
|
|
# to write and then to read and send response
|
|
# test requesting fc 15 multiple coils
|
|
# test pack c/I types as response
|
|
# register offset as attribute evaluated at runtime when sending and parsing (Comptrol etc.)
|
|
#
|
|
# clearBufferAfterParsing als Option, die den Rest des Buffers wegwirft
|
|
#
|
|
# get reading key (type / adr)
|
|
# filterEcho (wie in private post im Forum vorgeschlagen)
|
|
#
|
|
# async output for scan? table? with revregs etc.?
|
|
# get object-interpretations h123 -> Alle Variationen mit revregs und bswap und unpacks ...
|
|
#
|
|
# average response time per modbus id in profiling
|
|
#
|
|
# attr with a list of set commands / requests to launch when polling (Helios support)
|
|
#
|
|
# set/get definition with multiple requests as raw containig opt. readings / input
|
|
#
|
|
|
|
|
|
####################################################################################
|
|
# Internals / data structures
|
|
####################################################################################
|
|
|
|
# $hash->{MODBUSID} Modbus ID that this device is responsible for
|
|
|
|
# $hash->{Interval} Interval for cyclic request of a master device
|
|
# $hash->{RELAY} used for mode relay: name of a master device where we forward requests to
|
|
# $hash->{DeviceName} needed by DevIo to get Device, Port, Speed etc.
|
|
# $hash->{IODev} hash of the io device or this device itself if connecting through tcp
|
|
# $hash->{defptr} reference to the name of the logical device responsible for an id (defptr}{lName} => id
|
|
# $hash->{TCPConn} set to 1 if connecting through tcp/ip
|
|
# $hash->{TCPServer} set to 1 if this is a tcp server / listening device (not a connection itself)
|
|
# $hash->{TCPChild} set to 1 if this is a tcp server connection (child of a devive with TCPServer = 1)
|
|
# $hash->{EXPECT} internal state - what are we waiting for
|
|
# for master this can only be response or idle
|
|
# for slave / relay (=receiving side of a relay) it can only be request or response while we are parsing something not for us
|
|
# for passive it can be only request / response
|
|
#
|
|
|
|
# $hash->{MODE} can be master, slave, relay or passive - set during ld define
|
|
# relay is special because it to another master device to pass over requests to
|
|
|
|
# $hash->{FRAME} the frame just received, beeing parsed / handled
|
|
|
|
|
|
# $hash->{REQUEST} the request just received, beeing parsed / handled.
|
|
# It is set in HandleRequest as slave -> send reply, done synchronously
|
|
# or in HandleRequest as relay -> queue via master side where a modified copy
|
|
# of $hash->{REQUEST} will be stored
|
|
# or ProcessRequestQueue (master) -> take from queue, send -> wait for reply
|
|
#
|
|
# $hash->{RESPONSE} the response just received, beeing parsed / handled or created
|
|
#
|
|
# both are destroyed after HandleResponse
|
|
#
|
|
|
|
|
|
####################
|
|
# more explanations
|
|
####################
|
|
|
|
# if a logical device uses a physical device as io device, then $hash->{MODE}
|
|
# is copied to the physical device and locks this device into this mode.
|
|
#
|
|
# $hash->{PROTOCOL} can be RTU, ASCII or TCP
|
|
# as with MODE the PROTOCOL key is also copied and locked to the physical io device
|
|
#
|
|
# $hash->{DEST} contains ip address/port if connection through tcp
|
|
|
|
|
|
# phys connection proto mode on physical device
|
|
#
|
|
# serial/tcp rtu / ascii master and slave at same time not working,
|
|
# slave can not hear master / only one master per line
|
|
# also master and passive at sime time does not make sense
|
|
# also slave and passive is useless
|
|
# so if one logical device is passive, physical device can be locked passive
|
|
# if one is master or slave, physical can be set to same
|
|
#
|
|
# serial rtu / ascii passive possible, physical then can also be locked.
|
|
#
|
|
# serial tcp nonsense
|
|
#
|
|
# tcp rtu / ascii passive not possible, only master / slave. phys = logical
|
|
# tcp same.
|
|
|
|
# so when definig / assigning iodev, mode can be locked on physical side.
|
|
# same applies to protocol. rtu and ascii over same physical line is nonsense.
|
|
|
|
# for connections over tcp (Modbus TCP or RTU/ASCII over TCP $ioHash = $hash during define
|
|
# so $hash->{MODBUSID}, $hash->{PROTOCOL}, $hash->{MODE}, $hash->{IODev} is available
|
|
|
|
# for serial connections at runtime or when physical is already there when logical is defined
|
|
# and also for serial connections at startup when physical is not present when logical is defined
|
|
# NotifyFn is triggered at INITIALIZED, REREADCFG and MODIFIED.
|
|
# here ModbusLD_GetIOHash($hash) is called where everything should happen (call register etc.)
|
|
|
|
# for enable after disable on physical side everything is done. On logical side GetIOHash is called again.
|
|
# for attr IODev SetIODev is called
|
|
# ReadyFn also doesnt change anything regarding IODev / Registration
|
|
|
|
# So mainly things are handled after a define / initialized which triggers NotifyFn for every device
|
|
# Notify calls GetIoHash which calls SetIODev
|
|
|
|
#
|
|
# Exprs und Maps
|
|
# --------------
|
|
#
|
|
# Fhem Master Expr Register in externem Gerät (read) Readings in Fhem # implemented in ParseDataString
|
|
# Fhem Slave Expr Werte von externem Gerät (write) Readings in Fhem # implemented in ParseDataString
|
|
#
|
|
# Fhem Master setexpr Benutzereingabe (set->write) Register in externem Gerät # implemented in Set
|
|
# Fhem Slave setexpr Readings in Fhem (read) Register zu externem Gerät # implemented in PackObj
|
|
#
|
|
#
|
|
# Fhem Master Map Registerdarstellung extern (read) Readings in Fhem # implemented in ParseDataString
|
|
# Fhem Slave Map Werte von externem Gerät (write) Readings in Fhem # implemented in ParseDataString
|
|
#
|
|
# Fhem Master revMap Benutzereingabe (set->write) Register in externem Gerät # implemented in Set
|
|
# Fhem Slave revMap Readings in Fhem (read) Register in externem Gerät # implemented in PackObj
|
|
#
|
|
|
|
|
|
package Modbus;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use GPUtils qw(:all);
|
|
use SetExtensions qw(:all);
|
|
use Time::HiRes qw(gettimeofday tv_interval sleep); # work with floats, not just full seconds
|
|
use POSIX qw(strftime);
|
|
use Encode qw(decode encode);
|
|
use Scalar::Util qw(looks_like_number);
|
|
use TcpServerUtils qw(:all);
|
|
use DevIo;
|
|
use FHEM::HTTPMOD::Utils qw(:all);
|
|
use Scalar::Util qw(weaken); # needed for backlinks in queue structures (see chapter 11 in PBP / memory leak reported with relays)
|
|
|
|
use Exporter ('import');
|
|
our @EXPORT_OK = qw();
|
|
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
|
|
|
|
BEGIN { # functions / variables needed from package main
|
|
GP_Import( qw(
|
|
CommandAttr
|
|
CommandDeleteAttr
|
|
CommandDelete
|
|
addToDevAttrList
|
|
AttrVal
|
|
ReadingsVal
|
|
ReadingsTimestamp
|
|
readingsSingleUpdate
|
|
readingsBeginUpdate
|
|
readingsBulkUpdate
|
|
readingsEndUpdate
|
|
InternalVal
|
|
makeReadingName
|
|
goodReadingName
|
|
DoTrigger
|
|
asyncOutput
|
|
|
|
Log3
|
|
RemoveInternalTimer
|
|
InternalTimer
|
|
deviceEvents
|
|
EvalSpecials
|
|
AnalyzePerlCommand
|
|
CheckRegexp
|
|
IsDisabled
|
|
|
|
gettimeofday
|
|
FmtDateTime
|
|
GetTimeSpec
|
|
fhemTimeLocal
|
|
time_str2num
|
|
rtrim
|
|
|
|
DevIo_OpenDev
|
|
DevIo_SimpleWrite
|
|
DevIo_SimpleRead
|
|
DevIo_CloseDev
|
|
DevIo_IsOpen
|
|
DevIo_Disconnected
|
|
DevIo_getState
|
|
DevIo_setStates
|
|
SetExtensions
|
|
|
|
TcpServer_Open
|
|
TcpServer_Accept
|
|
TcpServer_SetSSL
|
|
TcpServer_Close
|
|
|
|
featurelevel
|
|
defs
|
|
modules
|
|
attr
|
|
init_done
|
|
));
|
|
|
|
# function to be visible in package main as Modbus_Name
|
|
GP_Export( qw(
|
|
Initialize
|
|
));
|
|
|
|
# special case to be used by legacy Fhem modules built on Modbus ...
|
|
*main::ModbusLD_Initialize = *Modbus::InitializeLD;
|
|
*main::ModbusLD_Define = *Modbus::DefineLDFn;
|
|
*main::ModbusLD_Undef = *Modbus::UndefLDFn;
|
|
*main::ModbusLD_Set = *Modbus::SetLDFn;
|
|
*main::ModbusLD_Get = *Modbus::GetLDFn;
|
|
*main::ModbusLD_Attr = *Modbus::AttrLDFn;
|
|
*main::Modbus_Notify = *Modbus::NotifyFn;
|
|
|
|
};
|
|
|
|
my $Module_Version = '4.5.5 - 9.5.2023';
|
|
|
|
my $PhysAttrs = join (' ',
|
|
'queueDelay',
|
|
'queueMax',
|
|
'queueTimeout',
|
|
'busDelay',
|
|
'clientSwitchDelay',
|
|
'frameGap',
|
|
'dropQueueDoubles:0,1',
|
|
'enableQueueLengthReading:0,1',
|
|
'retriesAfterTimeout',
|
|
'profileInterval',
|
|
'openTimeout',
|
|
'nextOpenDelay',
|
|
'nextOpenDelay2',
|
|
'maxTimeoutsToReconnect', # for Modbus over TCP/IP only
|
|
'skipGarbage:0,1',
|
|
'requestDelay', # for debugging / testing / simulations
|
|
'timeoutLogLevel:3,4',
|
|
'closeAfterResponse:0,1,2', # for Modbus over TCP/IP only (1= close after queue is done, 2= close after each response)
|
|
'showError:0,1',
|
|
'silentReconnect:0,1');
|
|
|
|
my $LogAttrs = join (' ',
|
|
'IODev', # fhem.pl macht dann $hash->{IODev} = $defs{$ioname}
|
|
'queueMax',
|
|
'alignTime',
|
|
'enableControlSet:0,1',
|
|
'enableSetInactive:0,1',
|
|
'nonPrioritizedSet:0,1',
|
|
'nonPrioritizedGet:0,1',
|
|
'sortUpdate:0,1',
|
|
'cacheUpdateHash:0,1',
|
|
'cacheParseInfo:0,1',
|
|
'propagateVerbose:0,1',
|
|
'connectionsRoom',
|
|
'serverIdExpr',
|
|
'scanDelay');
|
|
|
|
my $CommonAttrs =
|
|
'disable:0,1';
|
|
|
|
my $ObjAttrs = join (' ',
|
|
'obj-[cdih][0-9]+-reading',
|
|
'obj-[cdih][0-9]+-name',
|
|
'obj-[cdih][0-9]+-min',
|
|
'obj-[cdih][0-9]+-max',
|
|
'obj-[cdih][0-9]+-hint',
|
|
'obj-[cdih][0-9]+-map',
|
|
'obj-[cdih][0-9]+-mapDefault',
|
|
'obj-[cdih][0-9]+-rmapDefault',
|
|
'obj-[cdih][0-9]+-set',
|
|
'obj-[cdih][0-9]+-setexpr',
|
|
'obj-[cdih][0-9]+-textArg',
|
|
'obj-[cdih][0-9]+-noArg',
|
|
'obj-[cdih][0-9]+-revRegs',
|
|
'obj-[cdih][0-9]+-bswapRegs',
|
|
'obj-[cdih][0-9]+-len',
|
|
'obj-[cdih][0-9]+-unpack',
|
|
'obj-[cdih][0-9]+-decode',
|
|
'obj-[cdih][0-9]+-encode',
|
|
'obj-[cdih][0-9]+-expr',
|
|
'obj-[cdih][0-9]+-ignoreExpr',
|
|
'obj-[cdih][0-9]+-format',
|
|
'obj-[cdih][0-9]+-type',
|
|
'obj-[cdih][0-9]+-showGet',
|
|
'obj-[cdih][0-9]+-allowWrite',
|
|
'obj-[cdih][0-9]+-group',
|
|
'obj-[cdih][0-9]+-poll',
|
|
'obj-[cdih][0-9]+-polldelay',
|
|
'obj-[cdih][0-9]+-overrideFCread', # override fc for read operation
|
|
'obj-[cdih][0-9]+-overrideFCwrite' # override fc for write operation
|
|
);
|
|
|
|
my $DevAttrs = join (' ',
|
|
'dev-([cdih]-)?read', # override fc for type and read
|
|
'dev-([cdih]-)?write', # override fc for type and qrite
|
|
'dev-([cdih]-)?combine',
|
|
'dev-([cdih]-)?allowShortResponses',
|
|
'dev-([cdih]-)?addressErrCode',
|
|
'dev-([cdih]-)?valueErrCode',
|
|
'dev-([cdih]-)?notAllowedErrCode',
|
|
|
|
'dev-([cdih]-)?defRevRegs',
|
|
'dev-([cdih]-)?defBswapRegs',
|
|
'dev-([cdih]-)?defLen',
|
|
'dev-([cdih]-)?defUnpack',
|
|
'dev-([cdih]-)?defDecode',
|
|
'dev-([cdih]-)?defEncode',
|
|
'dev-([cdih]-)?defExpr',
|
|
'dev-([cdih]-)?defSet',
|
|
'dev-([cdih]-)?defHint',
|
|
'dev-([cdih]-)?defSetexpr',
|
|
'dev-([cdih]-)?defIgnoreExpr',
|
|
'dev-([cdih]-)?defFormat',
|
|
'dev-([cdih]-)?defShowGet',
|
|
'dev-([cdih]-)?defAllowWrite',
|
|
'dev-([cdih]-)?defPoll',
|
|
'dev-([cdih]-)?defPolldelay',
|
|
'dev-h-brokenFC3',
|
|
'dev-d-brokenFC2',
|
|
'dev-c-brokenFC5',
|
|
|
|
'dev-type-[A-Za-z0-9_]+-unpack',
|
|
'dev-type-[A-Za-z0-9_]+-len',
|
|
'dev-type-[A-Za-z0-9_]+-encode',
|
|
'dev-type-[A-Za-z0-9_]+-decode',
|
|
'dev-type-[A-Za-z0-9_]+-revRegs',
|
|
'dev-type-[A-Za-z0-9_]+-bswapRegs',
|
|
'dev-type-[A-Za-z0-9_]+-format',
|
|
'dev-type-[A-Za-z0-9_]+-expr',
|
|
'dev-type-[A-Za-z0-9_]+-map',
|
|
'dev-type-[A-Za-z0-9_]+-hint',
|
|
'dev-type-[A-Za-z0-9_]+-set',
|
|
|
|
'dev-timing-timeout',
|
|
'dev-timing-serverTimeout',
|
|
'dev-timing-serverTimeoutAbs', # just for testing
|
|
'dev-timing-sendDelay',
|
|
'dev-timing-commDelay',
|
|
|
|
'dev-fc[\d]+Response-unpack', # custom function codes
|
|
'dev-fc[\d]+Response-fieldList', # $response hash keys like ADR, LEN, VALUES
|
|
'dev-fc[\d]+Response-fieldExpr-.*', # expression for above fields
|
|
|
|
'dev-fc[\d]+Request-unpack', # custom function codes
|
|
'dev-fc[\d]+Request-fieldList', # $request hash keys like ADR, LEN, VALUES
|
|
'dev-fc[\d]+Request-fieldExpr-.*', # expression for above fields
|
|
);
|
|
|
|
my @pduFields = ('ADR', 'LEN', 'TYPE', 'VALUES', 'PDULEXP'); # allowed fields in request- and response-hash for fieldList and fieldExpr
|
|
|
|
my %errCodes = (
|
|
'01' => 'illegal function',
|
|
'02' => 'illegal data address',
|
|
'03' => 'illegal data value',
|
|
'04' => 'slave device failure',
|
|
'05' => 'acknowledge',
|
|
'06' => 'slave device busy',
|
|
'08' => 'memory parity error',
|
|
'0a' => 'gateway path unavailable',
|
|
'0b' => 'gateway target failed to respond'
|
|
);
|
|
|
|
my %PDUOverhead = ( # bytes on top of the PDU (fcode, data)
|
|
'RTU' => 3, # id + checksum
|
|
'ASCII' => 7, # Start:, 2 Ziffern Id, 2 Ziffern LRC, CR LF
|
|
'TCP' => 7);
|
|
|
|
my %fcMap = (
|
|
1 => { read => 1, # this function code can read
|
|
type => 'c', # this handles object of type c
|
|
default => 1, # this is the default fc for this type and operation
|
|
objReturn => 1, # return an object in the response
|
|
},
|
|
2 => { read => 1,
|
|
type => 'd',
|
|
default => 1,
|
|
objReturn => 1,
|
|
},
|
|
3 => { read => 1,
|
|
type => 'h',
|
|
default => 1,
|
|
objReturn => 1,
|
|
},
|
|
4 => { read => 1,
|
|
type => 'i',
|
|
default => 1,
|
|
objReturn => 1,
|
|
},
|
|
5 => { write => 1, # this request is a write request and contains data
|
|
type => 'c',
|
|
default => 1,
|
|
objReturn => 1,
|
|
},
|
|
6 => { write => 1,
|
|
type => 'h',
|
|
default => 1,
|
|
objReturn => 1,
|
|
},
|
|
15 => { write => 1,
|
|
type => 'c',
|
|
},
|
|
16 => { write => 1,
|
|
type => 'h',
|
|
},
|
|
17 => { read => 1,
|
|
}
|
|
);
|
|
|
|
|
|
my %attrDefaults = (
|
|
'allowWrite' => { devDefault => 'defAllowWrite',
|
|
default => 0},
|
|
'bswapRegs' => { devDefault => 'defBswapRegs'},
|
|
'decode' => { devDefault => 'defDecode'},
|
|
'encode' => { devDefault => 'defEncode'},
|
|
'expr' => { devDefault => 'defExpr'},
|
|
'format' => { devDefault => 'defFormat'},
|
|
'hint' => { devDefault => 'defHint'},
|
|
'ignoreExpr' => { devDefault => 'defIgnoreExpr'},
|
|
'len' => { devDefault => 'defLen',
|
|
default => 1},
|
|
'map' => { devDefault => 'defMap'},
|
|
'max' => { default => ''},
|
|
'min' => { default => ''},
|
|
'poll' => { devDefault => 'defPoll',
|
|
default => 0},
|
|
'polldelay' => { devDefault => 'defPolldelay',
|
|
default => '0.5'},
|
|
'reading' => {},
|
|
'revRegs' => { devDefault => 'defRevRegs'},
|
|
'set' => { devDefault => 'defSet'},
|
|
'setexpr' => { devDefault => 'defSetexpr'},
|
|
'showGet' => { devDefault => 'defShowGet'},
|
|
'textArg' => {},
|
|
'type' => { default => '***NoTypeInfo***'},
|
|
'mapDefault' => { default => undef},
|
|
'rmapDefault' => { default => undef},
|
|
'unpack' => { devDefault => 'defUnpack',
|
|
default => 'n'},
|
|
);
|
|
|
|
|
|
my %builtInType = (
|
|
'signed short' => 'signed short big', # 16 bits signed integer big endian (high, low)
|
|
'signed short big' => { len => 1,
|
|
unpack => 's>'},
|
|
'unsigned short' => 'unsigned short big', # 16 bits unsigned big endian
|
|
'unsigned short big' => { len => 1,
|
|
unpack => 'n'},
|
|
|
|
'signed short little' => { len => 1, # 16 bits signed integer vax / little endian (low high)
|
|
unpack => 's<'},
|
|
'unsigned short little' => { len => 1,
|
|
unpack => 'v'},
|
|
|
|
'signed long' => 'signed long big', # 32 bits / 2 registers signed long integer big endian (high low)
|
|
'signed long big' => { len => 2,
|
|
unpack => 'l>'},
|
|
'unsigned long' => 'unsigned long big', # 32 bits / 2 registers unsigned long integer big endian
|
|
'unsigned long big' => { len => 2,
|
|
unpack => 'L>'},
|
|
|
|
'signed long little' => { len => 2, # 32 bits / 2 registers signed long integer vax / little endian (low high)
|
|
unpack => 'l<'},
|
|
'unsigned long little' => { len => 2,
|
|
unpack => 'L<'}, # 32 bits / 2 registers unsigned long integer vax / little endian (low high)
|
|
|
|
'real' => 'float32 big', # 32 bit floating point big endian
|
|
'float' => 'float32 big',
|
|
'float32' => 'float32 big',
|
|
'float32 big' => { len => 2,
|
|
unpack => 'f>'},
|
|
'float litte' => 'float32 little', # 32 bit floating point little endian
|
|
'float32 little' => { len => 2,
|
|
unpack => 'f<'},
|
|
|
|
'double' => 'float64 big', # 64 bit floating point big endian
|
|
'float64' => 'float64 big',
|
|
'float64 big' => { len => 4,
|
|
unpack => 'f>'},
|
|
'double little' => 'float64 little', # 64 bit floating point little endian
|
|
'float64 little' => { len => 4,
|
|
unpack => 'f<'},
|
|
|
|
'string' => { unpack => 'a*', # string / byte array
|
|
len => 2}, # default len 2 - should be overwritten
|
|
);
|
|
|
|
|
|
###########################################################
|
|
# _initialize for the physical io device,
|
|
# exported as Modbus_Initialize
|
|
# called when the module is lodaded by Fhem
|
|
sub Initialize {
|
|
my $modHash = shift;
|
|
|
|
$modHash->{ReadFn} = \&Modbus::ReadFn;
|
|
$modHash->{ReadyFn} = \&Modbus::ReadyFn;
|
|
$modHash->{DefFn} = \&Modbus::DefineFn;
|
|
$modHash->{UndefFn} = \&Modbus::UndefFn;
|
|
$modHash->{NotifyFn} = \&Modbus::NotifyFn;
|
|
$modHash->{AttrFn} = \&Modbus::AttrFn;
|
|
|
|
$modHash->{AttrList} = join (' ',
|
|
'do_not_notify:1,0',
|
|
$PhysAttrs,
|
|
$CommonAttrs,
|
|
$main::readingFnAttributes);
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################
|
|
# initialize logical device
|
|
# needs to be visible like this from Device-Modules based on Modbus
|
|
sub InitializeLD {
|
|
my ($modHash) = @_;
|
|
|
|
$modHash->{DefFn} = \&Modbus::DefineLDFn; # functions are provided by the Modbus base module
|
|
$modHash->{UndefFn} = \&Modbus::UndefLDFn;
|
|
$modHash->{ReadFn} = \&Modbus::ReadFn;
|
|
$modHash->{ReadyFn} = \&Modbus::ReadyFn;
|
|
$modHash->{AttrFn} = \&Modbus::AttrLDFn;
|
|
$modHash->{SetFn} = \&Modbus::SetLDFn;
|
|
$modHash->{GetFn} = \&Modbus::GetLDFn;
|
|
$modHash->{NotifyFn} = \&Modbus::NotifyFn;
|
|
|
|
$modHash->{AttrList}= join (' ',
|
|
'do_not_notify:1,0',
|
|
$LogAttrs,
|
|
$CommonAttrs,
|
|
$main::readingFnAttributes);
|
|
|
|
$modHash->{ObjAttrList} = $ObjAttrs;
|
|
$modHash->{DevAttrList} = $DevAttrs;
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################################
|
|
# Define for the physical serial base device
|
|
# modbus id, Intervall don't live here but in the logical device
|
|
# Also Modbus over TCP is opened in the logical open
|
|
sub DefineFn {
|
|
my $ioHash = shift; # new hash of the device to be created
|
|
my $def = shift; # definition string
|
|
my @a = split(/\s+/, $def);
|
|
my $name = shift @a; # name of the device to be created
|
|
my $type = shift @a; # type / module to be used
|
|
my $dev = shift @a; # serial device
|
|
|
|
return "wrong syntax: define <name> $type [tty-devicename|none]" if (!$dev);
|
|
|
|
if ($dev =~ /@[\d]+/ || $dev =~ /[Nn]one/) {
|
|
$ioHash->{SerialConn} = 1;
|
|
delete $ioHash->{TCPConn};
|
|
} else {
|
|
$ioHash->{TCPConn} = 1;
|
|
$dev .= ':502' if ($dev !~ /.*:[0-9]/); # add default port if no port specified
|
|
delete $ioHash->{SerialConn};
|
|
}
|
|
$ioHash->{devioNoSTATE} = 1; # let stateFormat do its thing, just set the reading 'state', not the Internal STATE
|
|
$ioHash->{DeviceName} = $dev; # needed by DevIo to get Device, Port, Speed etc.
|
|
$ioHash->{IODev} = $ioHash; # point back to self to make getIOHash easier
|
|
$ioHash->{NOTIFYDEV} = 'global'; # NotifyFn nur aufrufen wenn global events (INITIALIZED)
|
|
DoClose($ioHash); # make sure everything is losed initally, set state to disconnected
|
|
|
|
Log3 $name, 4, "$name: defined as $dev";
|
|
return; # open is done later from NOTIFY
|
|
}
|
|
|
|
|
|
|
|
########################################################################
|
|
# define of the logical device
|
|
sub DefineLDFn {
|
|
my $hash = shift;
|
|
my $def = shift;
|
|
my ($name, $module, $id, $interval, $mode, $ipPort, $proto, $relay, $logInfo);
|
|
|
|
my $rxIP = qr{ (?!ASCII|RTU|TCP)\S+ }xms;
|
|
my $rxPort = qr{ [0-9]+ }xms;
|
|
my $rxName = qr{ (?<name> \S+) }xms;
|
|
my $rxModule = qr{ (?<module> \S+) }xms;
|
|
my $rxId = qr{ (?:id)? (?<id> [0-9]+) }xms;
|
|
my $rxDest = qr{ (?:destination)? (?<ipport> $rxIP(?:\:$rxPort)?) }xms;
|
|
my $rxListen = qr{ (?:listen)? (?<ipport> $rxIP\:$rxPort) }xms;
|
|
my $rxProto = qr{ (?<proto> RTU|ASCII|TCP) }xms;
|
|
my $rxInterv = qr{ (?:interval)? (?<interval> [0-9]+ (?:\.[0-9]+)? ) }xms;
|
|
my $rxRelay = qr{ (?<relay> \S+) }xms;
|
|
my $rxSp = qr{ \s+ }xms;
|
|
|
|
# classic master define
|
|
if ($def =~ m{\A $rxName $rxSp $rxModule # DevName, Module
|
|
$rxSp $rxId # ModbusId
|
|
$rxSp $rxInterv # Interval
|
|
(?: $rxSp $rxDest )? # optional IP:Port for TCP destination
|
|
(?: $rxSp $rxProto )? \z # optional protocol (RTU|ASCII|TCP)
|
|
}xms) {
|
|
( $name, $module, $id, $interval, $ipPort, $proto)
|
|
= ($+{name}, $+{module}, $+{id}, $+{interval}, $+{ipport}, $+{proto});
|
|
$mode = 'master';
|
|
$logInfo = " and interval $interval" . ($ipPort ? ", connection to $ipPort" : "");
|
|
}
|
|
# slave (=server) define
|
|
elsif ($def =~ m{\A $rxName $rxSp $rxModule
|
|
$rxSp $rxId
|
|
$rxSp (?: slave | server)
|
|
(?: $rxSp $rxListen )?
|
|
(?: $rxSp $rxProto )? \z }xms) {
|
|
( $name, $module, $id, $ipPort, $proto)
|
|
= ($+{name}, $+{module}, $+{id}, $+{ipport}, $+{proto});
|
|
$mode = 'slave';
|
|
$logInfo = ($ipPort ? " listening at $ipPort" : ' with connection through io device');
|
|
}
|
|
# passive define
|
|
elsif ($def =~ m{\A $rxName $rxSp $rxModule
|
|
$rxSp $rxId
|
|
$rxSp passive
|
|
(?: $rxSp $rxProto )? \z }xms) {
|
|
$mode = 'passive';
|
|
( $name, $module, $id, $proto)
|
|
= ($+{name}, $+{module}, $+{id}, $+{proto});
|
|
}
|
|
# relay define
|
|
elsif ($def =~ m{\A $rxName $rxSp $rxModule
|
|
$rxSp $rxId
|
|
$rxSp relay
|
|
(?: $rxSp $rxListen )?
|
|
(?: $rxSp $rxProto )?
|
|
$rxSp to $rxSp $rxRelay \z }xms) {
|
|
( $name, $module, $id, $interval, $ipPort, $proto, $relay)
|
|
= ($+{name}, $+{module}, $+{id}, $+{interval}, $+{ipport}, $+{proto}, $+{relay});
|
|
$mode = 'relay';
|
|
$logInfo = ($ipPort ? " listening at $ipPort" : " receiving through IODev") . " and relaying to device $relay";
|
|
}
|
|
else {
|
|
($name, $module) = ($def =~ /(\S+)\s+(\S+)\s+.*/);
|
|
return "Usage: define <name> $module <id> <interval>|slave|server|relay|passive [host:port] [RTU|ASCII|TCP] [to <relayMasterDevice>]"
|
|
}
|
|
|
|
$hash->{MODBUSID} = $id;
|
|
$hash->{MODE} = $mode;
|
|
$hash->{PROTOCOL} = $proto // 'RTU';
|
|
Log3 $name, 4, "$name: defined $mode with id $id, protocol $hash->{PROTOCOL}" . ($logInfo // '');
|
|
|
|
# for Modbus TCP physical hash = logical hash so MODE is set for physical device as well.
|
|
# for Modbus over IODev this is set when IODev Attr and GetIOHash is called
|
|
# or later when it is needed and GetIOHash is called
|
|
|
|
# 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.
|
|
|
|
$hash->{'.getList'} = '';
|
|
$hash->{'.setList'} = '';
|
|
$hash->{'.updateSetGet'} = 1;
|
|
$hash->{NOTIFYDEV} = 'global'; # NotifyFn nur aufrufen wenn global events (INITIALIZED etc.)
|
|
$hash->{MODULEVERSION} = "Modbus $Module_Version";
|
|
|
|
if ($interval) {
|
|
$hash->{Interval} = $interval;
|
|
} else {
|
|
delete $hash->{Interval}; # keep display of internals in Fhemweb short
|
|
}
|
|
|
|
if ($relay) {
|
|
$hash->{RELAY} = $relay;
|
|
} else {
|
|
delete $hash->{RELAY};
|
|
}
|
|
|
|
if ($ipPort) { # Modbus über TCP mit IP Adresse (TCP oder auch RTU/ASCII über TCP)
|
|
$ipPort .= ':502' if ($ipPort !~ /.*:[0-9]/); # add default port if no port specified
|
|
$hash->{DeviceName} = $ipPort; # needed by DevIo to get Device, Port, Speed etc.
|
|
$hash->{IODev} = $hash; # Modul ist selbst IODev
|
|
$hash->{defptr}{$name} = $id; # logisches Gerät für die Id (selbes Device bei TCP)
|
|
$hash->{TCPConn} = 1;
|
|
$hash->{TCPServer} = 1 if ($mode eq 'slave' || $mode eq 'relay');
|
|
$hash->{'.AttrList'} = $modules{$hash->{TYPE}}{AttrList} . ' ' . $PhysAttrs; # add physical attributes to TCP devices
|
|
}
|
|
else {
|
|
$ipPort = '';
|
|
delete $hash->{TCPConn};
|
|
delete $hash->{TCPServer};
|
|
delete $hash->{TCPChild};
|
|
}
|
|
GoToState($hash, 'disconnected'); # initial state after define - might modify to disabled / inactive
|
|
# connection will be opened later in NotifyFN (INITIALIZED, DEFINED, MODIFIED, ...)
|
|
# for serial connections we use a separate physical device. This is set in Notify
|
|
return;
|
|
}
|
|
|
|
|
|
|
|
#####################################
|
|
# delete physical Device
|
|
sub UndefFn {
|
|
my $ioHash = shift;
|
|
my $arg = shift;
|
|
my $name = $ioHash->{NAME};
|
|
|
|
# device is already in the process of being deleted so we should not issue commandDelete inside _Close again
|
|
# dont check isOpen, call close even if closed and potentially on readyfn list
|
|
DoClose($ioHash, {NODELETE => 1});
|
|
|
|
# lösche auch die Verweise aus logischen Modulen auf dieses physische.
|
|
foreach my $d (keys %{$ioHash->{defptr}}) { # go through all logical devices using this physical
|
|
Log3 $name, 4, "$name: Undef is removing IO device for $d";
|
|
my $lHash = $defs{$d};
|
|
delete $lHash->{IODev} if ($lHash); # remove IODev entry at logical device
|
|
UpdateTimer($lHash, \&Modbus::GetUpdate, 'stop'); # stop update timer of logical device
|
|
}
|
|
Profiler($ioHash, 'Idle'); # category to book time, Delay, Fhem, Idle, Read, Send or Wait
|
|
return;
|
|
}
|
|
|
|
|
|
|
|
#####################################
|
|
# device is being deleted
|
|
sub UndefLDFn {
|
|
my $hash = shift;
|
|
my $arg = shift;
|
|
my $name = $hash->{NAME};
|
|
Log3 $name, 5, "$name: _UnDef is preparing $name for deletion";
|
|
UnregAtIODev($hash);
|
|
|
|
# device is already in the process of being deleted so we should not issue commandDelete inside _Close again
|
|
# dont check isOpen, close even if closed and potentially on readyfn list
|
|
DoClose($hash, {NODELETE => 1});
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'stop');
|
|
RemoveInternalTimer ("scan:$name"); # scan timer for logical devices
|
|
# other timers are stopped in DoClose
|
|
|
|
delete $hash->{PROTOCOL}; # fix memory leak
|
|
delete $hash->{MODE};
|
|
delete $hash->{IODev};
|
|
delete $hash->{CHILDOF};
|
|
return;
|
|
}
|
|
|
|
|
|
#########################################################################
|
|
# AttrFn for physical serial device.
|
|
# special treatment only für attr disable.
|
|
sub AttrFn {
|
|
my $cmd = shift; # 'set' or 'del'
|
|
my $name = shift; # the Fhem device name
|
|
my $aName = shift; # attribute name
|
|
my $aVal = shift; # attribute value
|
|
my $hash = $defs{$name}; # reference to the Fhem device hash
|
|
|
|
Log3 $name, 5, "$name: attr $cmd $aName" . (defined($aVal) ? ", $aVal" : "");
|
|
if ($aName eq 'disable' && $init_done) { # only after init_done, otherwise see NotifyFN
|
|
# disable on a physical device
|
|
if ($cmd eq "set" && $aVal) {
|
|
Log3 $name, 4, "$name: attr disable set" . (IsOpen($hash) ? ", closing connection" : "");
|
|
GoToState($hash, 'disabled'); # close, stop timers and set state
|
|
}
|
|
elsif ($cmd eq 'del' || ($cmd eq 'set' && !$aVal)) {
|
|
Log3 $name, 4, "$name: attr disable removed";
|
|
DoOpen($hash) if (!AttrVal($name, 'closeAfterResponse', 0));
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
#########################################################################
|
|
# AttrFn for logical device.
|
|
sub AttrLDFn {
|
|
my $cmd = shift; # 'set' or 'del'
|
|
my $name = shift; # the Fhem device name
|
|
my $aName = shift; # attribute name
|
|
my $aVal = shift; # attribute value
|
|
my $hash = $defs{$name}; # reference to the Fhem device hash
|
|
|
|
#Log3 $name, 3, "$name: attr $aName " . ($aVal // 'undef') . " $cmd";
|
|
if ($cmd eq 'set') {
|
|
if ($aName =~ /expr/) { # validate all Expressions
|
|
return "Invalid Expression $aVal"
|
|
if (!EvalExpr($hash, {expr => $aVal, checkOnly => 1, action => "attr $aName"} ));
|
|
}
|
|
elsif ($aName =~ /unpack$/) { # validate all pack / unpack codes
|
|
#Log3 $name, 3, "$name: checking unpack code $aVal";
|
|
return if ($aVal eq 'none' && $aName =~ /dev-fc/);
|
|
local $SIG{__WARN__} = sub { Log3 $name, 3, "$name: checking unpack code $aVal in attr $aName created warning: @_"; };
|
|
my $result = eval {my $test = pack ($aVal, 1)};
|
|
if ($@) {
|
|
Log3 $name, 5, "$name: checking unpack code $aVal in attr $aName created error: $@";
|
|
return "Invalid pack / unpack code $aVal in attr $aName";
|
|
}
|
|
}
|
|
elsif ($aName =~ /dev-fc[\d]+.*-fieldExpr-(.*)/) {
|
|
#Log3 $name, 3, "$name: checking custom fc field expr for $1: $aVal";
|
|
if (!grep /^$1$/, @pduFields) {
|
|
return "invalid field $1 in attr $aName";
|
|
}
|
|
my $pduHash = {};
|
|
my $request = {};
|
|
my $response = {};
|
|
return "Invalid Expression $aVal"
|
|
if (!EvalExpr($hash, {expr => $aVal, '$request' => $request, '$pduHash' => $pduHash, '$response' => $response,
|
|
checkOnly => 1, action => "attr $aName"} ));
|
|
}
|
|
elsif ($aName =~ /dev-fc[\d]+.*-fieldList/) {
|
|
#Log3 $name, 3, "$name: checking custom fc field list $aVal";
|
|
my @flist = split ', ', $aVal;
|
|
foreach my $fld (@flist) {
|
|
return "invalid field $fld in attr $aName $aVal" if (!grep /^$fld$/, @pduFields);
|
|
}
|
|
}
|
|
elsif ($aName eq 'IODev') {
|
|
if ($hash->{TCPConn}) {
|
|
return "Attr IODev is not allowed for devices connected through TCP";
|
|
}
|
|
if (!SetIODev($hash, $aVal) && $init_done) { # set physical device proto, mode, reg/unreg
|
|
return "$aVal can not be used as IODev, see log for details";
|
|
}
|
|
}
|
|
elsif ($aName eq 'verbose') {
|
|
if ($aVal =~ /^[0-5]$/ && $hash->{TCPServer} && $hash->{FD}) {
|
|
Log3 $name, 4, "$name: propagate verbose level $aVal to connection subdevices";
|
|
foreach my $conn (keys %{$hash->{CONNECTHASH}}) {
|
|
my $chash = $hash->{CONNECTHASH}{$conn};
|
|
$attr{$chash->{NAME}}{verbose} = $aVal;
|
|
}
|
|
}
|
|
if (AttrVal($name, 'propagateVerbose', 0)) {
|
|
Log3 $name, 4, "$name: propagateVerbose is set, propagate level $aVal to IO device and potential relay device";
|
|
my $ioHash = GetIOHash($hash); # get ioName for meaningful logging
|
|
if ($ioHash && $ioHash != $hash) {
|
|
$attr{$ioHash->{NAME}}{verbose} = $aVal;
|
|
#Log3 $name, 3, "$name: verbose $aVal propagated to $ioHash->{NAME}";
|
|
}
|
|
if ($hash->{RELAY}) {
|
|
#Log3 $name, 4, "$name: propagateVerbose is set and RELAY is $hash->{RELAY}";
|
|
$attr{$hash->{RELAY}}{verbose} = $aVal;
|
|
#Log3 $name, 3, "$name: verbose $aVal propagated to $hash->{RELAY}";
|
|
my $rIoHash = GetRelayIO($hash);
|
|
#Log3 $name, 4, "$name: propagateVerbose is set and RELAY IO device is $rIoHash->{NAME}";
|
|
if ($rIoHash && $rIoHash != $hash) {
|
|
$attr{$rIoHash->{NAME}}{verbose} = $aVal;
|
|
#Log3 $name, 3, "$name: verbose $aVal propagated to $rIoHash->{NAME}";
|
|
}
|
|
}
|
|
}
|
|
}
|
|
elsif ($aName eq 'alignTime') {
|
|
my ($alErr, $alHr, $alMin, $alSec, undef) = GetTimeSpec($aVal);
|
|
return "Invalid Format $aVal in $aName : $alErr" if ($alErr);
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
|
|
$hash->{'.TimeAlign'} = fhemTimeLocal($alSec, $alMin, $alHr, $mday, $mon, $year);
|
|
$hash->{TimeAlignFmt} = FmtDateTime($hash->{'.TimeAlign'});
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'start'); # set / change timer
|
|
}
|
|
elsif (" $PhysAttrs " =~ /\ $aName[: ]/) {
|
|
if (!$hash->{TCPConn} && !$hash->{SerialConn}) {
|
|
Log3 $name, 3, "$name: attr $aName is only valid for physical Modbus devices or Modbus TCP - please use this attribute for your physical IO device" . ($hash->{IODev}{NAME} ? ' ' . $hash->{IODev}{NAME} : "");
|
|
return "attribute $aName is only valid for physical Modbus devices or Modbus TCP - please use this attribute for your physical IO device" . ($hash->{IODev}{NAME} ? ' ' . $hash->{IODev}{NAME} : "");
|
|
}
|
|
}
|
|
elsif ($aName =~ /^(obj-[cdih])[0-9]+-reading/) {
|
|
return "unsupported character in reading name $aName ".
|
|
"(not A-Za-z/\\d_\\.-)" if(!goodReadingName($aName));
|
|
}
|
|
elsif ($aName eq 'SSL') {
|
|
if (!$hash->{TCPConn}) {
|
|
Log3 $name, 3, "$name: attr $aName is only valid Modbus TCP slaves (=servers)";
|
|
return "attribute $aName is only valid for Modbus TCP slaves (=servers)";
|
|
}
|
|
TcpServer_SetSSL($hash); # check libs and set flag
|
|
if($hash->{CD}) {
|
|
my $ret = IO::Socket::SSL->start_SSL($hash->{CD});
|
|
Log3 $name, 4, "$hash->{NAME} start_SSL: $ret" if($ret);
|
|
}
|
|
}
|
|
|
|
if ($aName =~ /^(obj-[cdih])(0+([0-9]+))-/) {
|
|
# leading zero in obj-Attr detected
|
|
if (length($2) > 5) {
|
|
my $new = $1 . substr("00000", 0, 5 - length ($3)) . $3;
|
|
Log3 $name, 3, "$name: attr $aName address is too long, shortened to $new ($2/$3)";
|
|
$aName = $new;
|
|
}
|
|
if (!$hash->{LeadingZeros}) {
|
|
$hash->{LeadingZeros} = 1;
|
|
Log3 $name, 4, "$name: attr support for leading zeros in object addresses enabled. This might slow down the fhem modbus module a bit";
|
|
}
|
|
}
|
|
ManageUserAttr($hash, $aName);
|
|
}
|
|
elsif ($cmd eq 'del') {
|
|
#Log3 $name, 5, "$name: attr del $aName";
|
|
if ($aName =~ /obj-[cdih]0[0-9]+-/) {
|
|
if (!(grep {!/$aName/} grep {/obj-[cdih]0[0-9]+-/} keys %{$attr{$name}})) {
|
|
delete $hash->{LeadingZeros}; # no more leading zeros
|
|
}
|
|
}
|
|
elsif ($aName eq 'verbose') {
|
|
if ($hash->{TCPServer} && $hash->{FD}) {
|
|
Log3 $name, 5, "$name: delete verbose level in connection subdevices";
|
|
foreach my $conn (keys %{$hash->{CONNECTHASH}}) {
|
|
my $chash = $hash->{CONNECTHASH}{$conn};
|
|
delete $attr{$chash->{NAME}}{verbose};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($aName =~ /(^obj-)|(^dev-)/) {
|
|
delete $hash->{UPDATECACHE}; # cached update hash needs to be recalculated when obj / dev info changes
|
|
delete $hash->{PICACHE}; # cached ObjInfo and DevInfo results
|
|
delete $hash->{DICACHE}; # cached DevInfo results for custom FCs
|
|
}
|
|
$hash->{'.updateSetGet'} = 1;
|
|
#Log3 $name, 5, "$name: attr change set updateGetSetList to 1";
|
|
|
|
if ($aName eq 'disable' && $init_done) { # if not init_done, nothing to be done here (see NotifyFN)
|
|
if ($cmd eq "set" && $aVal) { # disable set on a logical device (not physical serial here!)
|
|
GoToState($hash, 'disabled'); # set state, close / stop timers
|
|
}
|
|
elsif ($cmd eq 'del' || ($cmd eq 'set' && !$aVal)) { # disable removed / cleared
|
|
Log3 $name, 4, "$name: attr disable removed";
|
|
GoToState($hash, 'enabled'); # set state, open / start update timer
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################################
|
|
# called from get / set if $hash->{'.updateSetGet'} is set
|
|
# which is done in define and attr
|
|
sub UpdateGetSetList {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}};
|
|
my $parseInfo = $hash->{parseInfo} // $modHash->{parseInfo};
|
|
my $devInfo = $hash->{deviceInfo} // $modHash->{deviceInfo};
|
|
$hash->{'.getList'} = '';
|
|
$hash->{'.setList'} = '';
|
|
if (AttrVal($name, "enableControlSet", 1)) { # special sets active (since 4.0 1 by default)
|
|
$hash->{'.setList'} = "reconnect:noArg saveAsModule createAttrsFromParseInfo ";
|
|
if ($hash->{MODE} && $hash->{MODE} eq 'master') {
|
|
$hash->{'.setList'} .= "interval reread:noArg stop:noArg start:noArg close:noArg ";
|
|
$hash->{'.setList'} .= "scanStop:noArg scanModbusObjects sendRaw ";
|
|
$hash->{'.setList'} .= "scanModbusId " if ($hash->{PROTOCOL} =~ /RTU|ASCII/);
|
|
}
|
|
if (AttrVal($name, 'enableSetInactive', 1)) {
|
|
$hash->{'.setList'} .= "inactive active ";
|
|
}
|
|
}
|
|
if ($hash->{MODE} && $hash->{MODE} eq 'master') {
|
|
my @ObjList = keys (%{$parseInfo});
|
|
foreach my $at (keys %{$attr{$name}}) {
|
|
if ($at =~ /^obj-(.*)-reading$/) {
|
|
push @ObjList, $1 if (!$parseInfo->{$1});
|
|
}
|
|
}
|
|
#Log3 $name, 5, "$name: UpdateGetSetList full object list: " . join (" ", @ObjList);
|
|
|
|
foreach my $objCombi (sort @ObjList) {
|
|
my $reading = ObjInfo($hash, $objCombi, 'reading');
|
|
my $showget = ObjInfo($hash, $objCombi, 'showGet');
|
|
my $set = ObjInfo($hash, $objCombi, 'set');
|
|
my $map = ObjInfo($hash, $objCombi, 'map');
|
|
my $hint = ObjInfo($hash, $objCombi, 'hint');
|
|
my $setopt;
|
|
$hash->{'.getList'} .= "$reading:noArg " if ($showget); # sichtbares get
|
|
|
|
if ($set) { # gibt es für das Reading ein SET?
|
|
$setopt = $reading . ($map ? ':' . MapToHint($map) : '');
|
|
$setopt = $reading . ':' . $hint if ($hint);
|
|
$hash->{'.setList'} .= "$setopt "; # add set option
|
|
}
|
|
}
|
|
}
|
|
Log3 $name, 5, "$name: UpdateSetList: setList=$hash->{'.setList'}";
|
|
Log3 $name, 5, "$name: UpdateSetList: getList=$hash->{'.getList'}";
|
|
$hash->{'.updateSetGet'} = 0;
|
|
return;
|
|
}
|
|
|
|
|
|
############################################################
|
|
# Get Funktion für logische Geräte / Module
|
|
sub GetLDFn {
|
|
my @getValArr = @_; # rest is optional values
|
|
my $hash = shift @getValArr; # reference to device hash
|
|
my $name = shift @getValArr; # device name
|
|
my $getName = shift @getValArr; # get option name
|
|
my $getVal = join(' ', @getValArr); # optional value after get name
|
|
my $objCombi = ObjKey($hash, $getName);
|
|
my $async = AttrVal($name, "nonPrioritizedGet", 0);
|
|
return "\"get $name\" needs at least one argument" if (!$getName);
|
|
Log3 $name, 4, "$name: get called with $getName " . ($objCombi ? "($objCombi)" : '') if ($getName ne '?');
|
|
|
|
if (!$objCombi) {
|
|
UpdateGetSetList($hash) if ($hash->{'.updateSetGet'});
|
|
#Log3 $name, 5, "$name: get $getName not found, return list $hash->{'.getList'}" if ($getName ne '?');
|
|
return "Unknown argument $getName, choose one of $hash->{'.getList'}";
|
|
}
|
|
my $msg = GetSetChecks($hash, $async);
|
|
return $msg if ($msg); # no other action because io device is not usable anyway
|
|
|
|
my $type = substr($objCombi, 0, 1);
|
|
my $adr = substr($objCombi, 1);
|
|
delete $hash->{gotReadings};
|
|
DoRequest($hash, {TYPE => $type, ADR => $adr, OPERATION => 'read', DBGINFO => "get $getName", FORCE => !$async});
|
|
# doRequest calls queueRequest and then either processRequestQueue diretly or sets timer so no further startQueueTimer necessary
|
|
#StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0}); # call processRequestQueue at next possibility (others waiting?)
|
|
if (!$async) {
|
|
my $err = ReadAnswer(GetIOHash($hash));
|
|
return $err if ($err);
|
|
}
|
|
return $hash->{gotReadings}{$getName};
|
|
}
|
|
|
|
|
|
################################################################
|
|
# check, encode / format the value to be set
|
|
# called from setLDFn
|
|
sub FormatSetVal {
|
|
my $hash = shift;
|
|
my $objCombi = shift;
|
|
my $setVal = shift;
|
|
my $name = $hash->{NAME};
|
|
|
|
my $unpack = ObjInfo($hash, $objCombi, 'unpack');
|
|
my $len = ObjInfo($hash, $objCombi, 'len');
|
|
my $type = substr($objCombi, 0, 1);
|
|
my $adr = substr($objCombi, 1);
|
|
my $fCode = GetFC($hash, {TYPE => $type, ADR => $adr, LEN => $len, OPERATION => 'write'});
|
|
my $rawVal = $setVal;
|
|
|
|
# 1. step: use reverse map if defined, return error if no match
|
|
$rawVal = MapConvert ($hash, {map => ObjInfo($hash, $objCombi, 'map'),
|
|
default => ObjInfo($hash, $objCombi, 'rmapDefault'), # default for rmapDefault is undef
|
|
val => $rawVal, reverse => 1, undefIfNoMatch => 1});
|
|
return (undef, "set value $setVal did not match defined map") if (!defined($rawVal));
|
|
|
|
# 2. step: check min / max if defined
|
|
if (!CheckRange($hash, {val => $rawVal, min => ObjInfo($hash, $objCombi, 'min'), max => ObjInfo($hash, $objCombi, 'max')} ) ) {
|
|
return (undef, "value $rawVal is not within defined min/max range");
|
|
}
|
|
if (!looks_like_number $rawVal && !ObjInfo($hash, $objCombi, 'textArg')) {
|
|
Log3 $name, 3, "$name: set value $rawVal is not numeric and textArg not specified";
|
|
return (undef, "Set Value $rawVal is not numeric and textArg not specified");
|
|
}
|
|
|
|
# 3. step: convert using setexpr if defined
|
|
$rawVal = EvalExpr($hash, {expr => ObjInfo($hash, $objCombi, 'setexpr'), val => $rawVal});
|
|
|
|
# 4. step: pack value
|
|
my $packedVal;
|
|
if ($type eq 'c' && $fCode == 5) { # special treatment when writing one coil (unless fc5 comes from overriding another type)
|
|
my $oneCode = uc DevInfo($hash, 'c', 'brokenFC5', 'FF00');
|
|
$packedVal = pack ('H4', ($rawVal ? $oneCode : '0000'));
|
|
Log3 $name, 5, "$name: set packed coil to hex " . unpack ('H*', $packedVal);
|
|
}
|
|
else { # other type or function code
|
|
$packedVal = pack ($unpack, $rawVal);
|
|
Log3 $name, 5, "$name: set packed hex " . unpack ('H*', $rawVal) . " with $unpack to hex " . unpack ('H*', $packedVal);
|
|
}
|
|
# 5. step: RevRegs / SwapRegs if needed
|
|
$packedVal = ReverseWordOrder($hash, $packedVal, $len) if (ObjInfo($hash, $objCombi, 'revRegs'));
|
|
$packedVal = SwapByteOrder($hash, $packedVal, $len) if (ObjInfo($hash, $objCombi, 'bswapRegs'));
|
|
return ($packedVal, undef);
|
|
}
|
|
|
|
|
|
################################################################
|
|
# set funktion für logische Geräte
|
|
sub SetLDFn {
|
|
my @setValArr = @_; # remainder is set values
|
|
my $hash = shift @setValArr; # reference to Fhem device hash
|
|
my $name = shift @setValArr; # Fhem device name
|
|
my $setName = shift @setValArr; # name of the set option
|
|
my $setVal = @setValArr ? join(' ', @setValArr) : undef; # set values as one string
|
|
my $async = AttrVal($name, 'nonPrioritizedSet', 0);
|
|
|
|
return "\"set $name\" needs at least an argument" if (!$setName);
|
|
|
|
if (AttrVal($name, 'enableControlSet', 1)) { # spezielle Sets freigeschaltet?
|
|
my $error = ControlSet($hash, $setName, $setVal);
|
|
return if (defined($error) && $error eq '0'); # control set found and done.
|
|
return $error if ($error); # error
|
|
# continue if ControlSet function returned undef
|
|
}
|
|
|
|
my $objCombi = ObjKey($hash, $setName);
|
|
|
|
Log3 $name, 4, "$name: set called with $setName " . ($objCombi ? "($objCombi) " : ' ') .
|
|
(defined($setVal) ? "setVal = $setVal" :'') if ($setName ne '?');
|
|
|
|
if (!$objCombi) {
|
|
UpdateGetSetList($hash) if ($hash->{'.updateSetGet'});
|
|
#Log3 $name, 5, "$name: set $setName not found, return list $hash->{'.setList'}" if ($setName ne '?');
|
|
return "Unknown argument $setName, choose one of $hash->{'.setList'}";
|
|
}
|
|
if (ObjInfo($hash, $objCombi, 'noArg')) {
|
|
$setVal = 1; # dummy value for noArg
|
|
Log3 $name, 4, "$name: set with noArg for $setName, using value 1";
|
|
}
|
|
elsif (!defined($setVal)) {
|
|
Log3 $name, 3, "$name: set without value for $setName";
|
|
return "No Value given to set $setName";
|
|
}
|
|
|
|
my $msg = GetSetChecks($hash, $async);
|
|
return $msg if ($msg); # no other action because io device is not usable anyway
|
|
|
|
my ($packedVal, $error) = FormatSetVal($hash, $objCombi, $setVal);
|
|
return $error if ($error);
|
|
|
|
my $type = substr($objCombi, 0, 1);
|
|
my $adr = substr($objCombi, 1);
|
|
my $len = ObjInfo($hash, $objCombi, 'len');
|
|
my $fCode = GetFC($hash, {TYPE => $type, ADR => $adr, LEN => $len, OPERATION => 'write'});
|
|
my $ioHash = GetIOHash($hash); # ioHash has been checked in GetSetChecks above already
|
|
DoRequest($hash, {TYPE => $type, ADR => $adr, LEN => $len, OPERATION => 'write', VALUES => $packedVal, FORCE => !$async, DBGINFO => "set $setName"});
|
|
# StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0}); # call processRequestQueue at next possibility (others waiting?)
|
|
# DoRequest should call QueueRequest which calls StartQueueTimer without delay ...
|
|
|
|
if (!$async) {
|
|
my $err = ReadAnswer($ioHash); # wait for the response
|
|
return $err if ($err);
|
|
}
|
|
if ($fCode == 15 || $fCode == 16) { # read after write
|
|
Log3 $name, 5, "$name: set is sending read after write";
|
|
DoRequest($hash, {TYPE => $type, ADR => $adr, OPERATION => 'read', FORCE => !$async, DBGINFO => "set $setName Rd"});
|
|
if (!$async) {
|
|
my $err = ReadAnswer($ioHash);
|
|
return "$err (in read after write for FCode $fCode)" if ($err);
|
|
}
|
|
}
|
|
return; # no return code if no error
|
|
}
|
|
|
|
|
|
########################################################################
|
|
# SET command - handle predefined control sets for logical device
|
|
sub ControlSet {
|
|
my $hash = shift;
|
|
my $setName = shift;
|
|
my $setVal = shift;
|
|
my $name = $hash->{NAME};
|
|
|
|
if ($setName eq 'interval') {
|
|
return 'set interval is only allowed when Fhem is Modbus master' if ($hash->{MODE} ne 'master');
|
|
if (!defined($setVal) || $setVal !~ m{ \A [0-9.]+ (\.[0-9]+)? \z}xms ) {
|
|
Log3 $name, 3, "$name: set interval $setVal not valid";
|
|
Log3 $name, 3, "$name: continuing with $hash->{Interval} (sec)" if ($hash->{Interval});
|
|
return 'No valid Interval specified';
|
|
}
|
|
$hash->{Interval} = $setVal;
|
|
Log3 $name, 4, "$name: set interval changed interval to $hash->{Interval} seconds";
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'start'); # set / change timer
|
|
return '0';
|
|
}
|
|
if ($setName eq 'reread') {
|
|
return "set reread is only allowed when Fhem is Modbus master" if ($hash->{MODE} ne 'master');
|
|
GetUpdate("reread:$name");
|
|
return '0';
|
|
}
|
|
if ($setName eq 'reconnect') {
|
|
if (!$hash->{TCPConn} && $hash->{TYPE} ne 'Modbus') {
|
|
Log3 $name, 3, "$name: reconnect only possible for physical or TCP connections, not for logical devices";
|
|
return 'reconnect only possible for physical or TCP connections, not for logical devices';
|
|
}
|
|
# todo: close and immediate reopen might case problems on windows with usb device - needs testing on windows
|
|
|
|
my $msg = CheckDisable($hash);
|
|
return $msg if ($msg);
|
|
|
|
DoOpen($hash, {CLOSEFIRST => 1}); # async but close first
|
|
return '0';
|
|
}
|
|
if ($setName eq 'close') {
|
|
if (!$hash->{TCPConn} && $hash->{TYPE} ne 'Modbus') {
|
|
Log3 $name, 3, "$name: close only possible for physical or TCP connections, not for logical devices";
|
|
return 'close only possible for physical or TCP connections, not for logical devices';
|
|
}
|
|
DoClose($hash); # should be called with hash of physical device but for TCP it's the same
|
|
return '0';
|
|
}
|
|
if ($setName eq 'active' && AttrVal($name, 'enableSetInactive', 1) ) {
|
|
return 'device is disabled' if (AttrVal($name, 'disable', 0));
|
|
GoToState($hash, 'active'); # set state, open / start update timer
|
|
return '0';
|
|
}
|
|
if ($setName eq 'inactive' && AttrVal($name, 'enableSetInactive', 1)) {
|
|
return 'device is disabled' if (AttrVal($name, 'disable', 0));
|
|
GoToState($hash, 'inactive'); # set state, close / stop timers
|
|
return '0';
|
|
}
|
|
if ($setName eq 'stop') {
|
|
return "set stop is only allowed when Fhem is Modbus master" if ($hash->{MODE} ne 'master');
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'stop');
|
|
return '0';
|
|
}
|
|
if ($setName eq 'start') {
|
|
my $msg = CheckDisable($hash);
|
|
return $msg if ($msg);
|
|
return 'set start is only allowed when Fhem is Modbus master' if ($hash->{MODE} ne 'master');
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'start'); # set / change timer
|
|
return '0';
|
|
}
|
|
if ($setName eq 'sendRaw') {
|
|
my $msg = CheckDisable($hash);
|
|
return $msg if ($msg);
|
|
return 'set sendRaw is only allowed when Fhem is Modbus master' if ($hash->{MODE} ne 'master');
|
|
|
|
my %requestData; # create new request structure
|
|
my $request = \%requestData;
|
|
|
|
$request->{MODBUSID} = $hash->{MODBUSID};
|
|
$request->{READING} = 'dummy';
|
|
$request->{TYPE} = '';
|
|
$request->{ADR} = 0;
|
|
$request->{LEN} = 0;
|
|
$request->{VALUES} = $setVal;
|
|
$request->{MASTERHASH} = $hash; # logical device in charge
|
|
$request->{TID} = int(rand(255)) if ($hash->{PROTOCOL} eq 'TCP'); # transaction id for Modbus TCP
|
|
$request->{FCODE} = 999; # dummy for raw sending
|
|
weaken $request->{MASTERHASH};
|
|
|
|
my $ioHash = GetIOHash($hash); # send queue is at physical hash
|
|
delete $ioHash->{RETRY};
|
|
QueueRequest($ioHash, $request); # queue and process / set queue timer depending on force
|
|
return '0';
|
|
}
|
|
|
|
if ($setName eq 'scanStop') {
|
|
Log3 $name, 4, '$name: scanStop - try asyncOutput to $hash';
|
|
my $cl = $hash->{CL};
|
|
asyncOutput($cl, 'Hallo <b>Du</b>');
|
|
|
|
my $msg = CheckDisable($hash);
|
|
return $msg if ($msg);
|
|
return "set scanStop is only allowed when Fhem is Modbus master" if ($hash->{MODE} ne 'master');
|
|
RemoveInternalTimer ("scan:$name");
|
|
delete $hash->{scanId};
|
|
delete $hash->{scanIdStart};
|
|
delete $hash->{scanIdEnd};
|
|
delete $hash->{scanOAdr};
|
|
delete $hash->{scanOStart};
|
|
delete $hash->{scanOEnd};
|
|
delete $hash->{scanOLen};
|
|
delete $hash->{scanOType};
|
|
return '0';
|
|
}
|
|
if ($setName eq 'scanModbusId') {
|
|
my $msg = CheckDisable($hash);
|
|
return $msg if ($msg);
|
|
return 'set scanModbusId is only allowed when Fhem is Modbus master' if ($hash->{MODE} ne 'master');
|
|
delete $hash->{scanOStart};
|
|
delete $hash->{scanOEnd};
|
|
$hash->{scanIdStart} = 1;
|
|
$hash->{scanIdEnd} = 255;
|
|
$hash->{scanOType} = 'h';
|
|
$hash->{scanOAdr} = 100;
|
|
$hash->{scanOLen} = 1;
|
|
if ($setVal && $setVal =~ /([0-9]+) *- *([0-9]+) +([hicd][0-9]+)/) {
|
|
$hash->{scanIdStart} = $1;
|
|
$hash->{scanIdEnd} = $2;
|
|
$hash->{scanOType} = substr($3,0,1);
|
|
$hash->{scanOAdr} = substr($3,1);
|
|
}
|
|
Log3 $name, 4, "$name: set scan range specified as Modbus Id $hash->{scanIdStart} to $hash->{scanIdEnd}" .
|
|
" with $hash->{scanOType}$hash->{scanOAdr}, Len ";
|
|
delete $hash->{scanId};
|
|
|
|
my $now = gettimeofday();
|
|
my $scanDelay = AttrVal($name, 'scanDelay', 1);
|
|
RemoveInternalTimer ("scan:$name");
|
|
InternalTimer($now+$scanDelay, \&Modbus::ScanIds, "scan:$name", 0);
|
|
return '0';
|
|
}
|
|
if ($setName eq 'scanModbusObjects') {
|
|
my $msg = CheckDisable($hash);
|
|
return $msg if ($msg);
|
|
return 'set scanModbusObjects is only allowed when Fhem is Modbus master' if ($hash->{MODE} ne 'master');
|
|
delete $hash->{scanId};
|
|
delete $hash->{scanIdStart};
|
|
delete $hash->{scanIdEnd};
|
|
$hash->{scanOType} = 'h';
|
|
$hash->{scanOStart} = '1';
|
|
$hash->{scanOEnd} = '16384';
|
|
$hash->{scanOLen} = '1';
|
|
if ($setVal && $setVal =~ /([hicd][0-9]+) *- *([hicd]?([0-9]+)) ?(len)? ?([0-9]+)?/) {
|
|
$hash->{scanOType} = substr($1,0,1);
|
|
$hash->{scanOStart} = substr($1,1);
|
|
$hash->{scanOEnd} = $3;
|
|
$hash->{scanOLen} = ($5 ? $5 : 1);
|
|
}
|
|
Log3 $name, 4, "$name: set scan $hash->{scanOType} from $hash->{scanOStart} to $hash->{scanOEnd} len $hash->{scanOLen}";
|
|
delete $hash->{scanOAdr};
|
|
|
|
my $now = gettimeofday();
|
|
my $scanDelay = AttrVal($name, 'scanDelay', 1);
|
|
RemoveInternalTimer ("scan:$name");
|
|
InternalTimer($now+$scanDelay, \&Modbus::ScanObjects, "scan:$name", 0);
|
|
return '0';
|
|
}
|
|
if ($setName eq 'saveAsModule') {
|
|
return SaveAsModule ($hash, $setVal);
|
|
}
|
|
if ($setName eq 'createAttrsFromParseInfo') {
|
|
return createAttrsFromParseInfo ($hash);
|
|
}
|
|
|
|
return; # no control set identified - continue with other sets
|
|
}
|
|
|
|
|
|
####################################################################
|
|
# create a Fhem module file based on the current configuration
|
|
# in attributes
|
|
sub createAttrsFromParseInfo {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}};
|
|
my $parseInfo = $modHash->{parseInfo};
|
|
my $devInfo = $modHash->{deviceInfo};
|
|
my $last = 'x';
|
|
|
|
#Log3 $name, 3, "$name: createAttrsFromParseInfo called, TYPE $hash->{TYPE}, parseInfo $parseInfo";
|
|
foreach my $a (sort keys %{$parseInfo}) {
|
|
if ($a =~ /([ihcd])(\d+)/) {
|
|
my $type = $1;
|
|
my $adr = $2;
|
|
foreach my $k (sort keys %{$parseInfo->{$a}}) {
|
|
my $attrName = "obj-$type$adr-$k";
|
|
my $val = $parseInfo->{$a}{$k};
|
|
#Log3 $name, 3, "$name: createAttrsFromParseInfo working on $attrName $val";
|
|
if (exists $attr{$name}{$attrName}) {
|
|
if ($attr{$name}{$attrName} ne $val) {
|
|
return "createAttrsFromParseInfo aborted because attr $attrName already exists with value $attr{$name}{$attrName} (parseInfo contains $val)";
|
|
}
|
|
}
|
|
CommandAttr(undef, "$name $attrName $val");
|
|
}
|
|
}
|
|
}
|
|
foreach my $a (sort keys %{$devInfo}) {
|
|
foreach my $k (sort keys %{$devInfo->{$a}}) {
|
|
my $attrName = "dev-$a-$k";
|
|
my $val = $devInfo->{$a}{$k};
|
|
#Log3 $name, 3, "$name: createAttrsFromParseInfo working on $attrName $val";
|
|
if (exists $attr{$name}{$attrName}) {
|
|
if ($attr{$name}{$attrName} ne $val) {
|
|
return "createAttrsFromParseInfo aborted because attr $attrName already exists with value $attr{$name}{$attrName} (devInfo contains $val)";
|
|
}
|
|
}
|
|
CommandAttr(undef, "$name $attrName $val");
|
|
}
|
|
}
|
|
Log3 $name, 4, "$name: createAttrsFromParseInfo done";
|
|
return '0';
|
|
}
|
|
|
|
|
|
####################################################################
|
|
# create a Fhem module file based on the current configuration
|
|
# in attributes
|
|
sub SaveAsModule {
|
|
my $hash = shift;
|
|
my $fName = shift;
|
|
my $name = $hash->{NAME};
|
|
my $tFile = 'lib/FHEM/Modbus/modTemplate';
|
|
my $oFile = "/tmp/98_ModbusGen$fName.pm";
|
|
my $tmpl;
|
|
if (!open($tmpl, "<", $tFile)) {
|
|
Log3 $name, 3, "$name: Cannot open template file $tFile";
|
|
return "cannot open $tFile";
|
|
};
|
|
my $content = '';
|
|
while (<$tmpl>) {
|
|
$content .= $_;
|
|
}
|
|
close $tmpl;
|
|
Log3 $name, 4, "$name: template file $tFile read successfully";
|
|
|
|
my $t = '';
|
|
my $last = 'x';
|
|
foreach my $a (sort keys %{$attr{$name}}) {
|
|
if ($a =~ /^obj-([^\-]+)-(.*)$/) {
|
|
my $adr = $1;
|
|
my $key = $2;
|
|
if ($1 ne $last) {
|
|
$t .= sprintf "%26s", "},\n" if ($last ne "x");
|
|
$t .= sprintf "%2s", " " . sprintf "%16s%s", "\"$adr\"", " => { ";
|
|
$last = $adr;
|
|
} else {
|
|
$t .= sprintf "%25s", " ";
|
|
}
|
|
my $aVal = $attr{$name}{$a};
|
|
$aVal =~ s/\'/\\\'/g;
|
|
$t .= sprintf "%15s%s", "\'".$key."\'", " => \'$aVal\',\n";
|
|
}
|
|
}
|
|
$t .= sprintf "%28s", "}\n);\n\n" if ($last ne 'x');
|
|
|
|
$t .= "my %ModbusGen${fName}deviceInfo = (\n";
|
|
$last = "x";
|
|
foreach my $a (sort keys %{$attr{$name}}) {
|
|
if ($a =~ /^dev-((type-)?[^\-]+)-(.*)$/) {
|
|
if ($1 ne $last) {
|
|
$t .= sprintf "%26s", "},\n" if ($last ne "x");
|
|
$t .= sprintf "%2s", " " . sprintf "%16s%s", "\"$1\"", " => { ";
|
|
$last = $1;
|
|
} else {
|
|
$t .= sprintf "%25s", " ";
|
|
}
|
|
$t .= sprintf "%15s%s", "\'".$3."\'", " => \'$attr{$name}{$a}\',\n";
|
|
}
|
|
}
|
|
$t .= sprintf "%28s", "}\n);\n\n" if ($last ne 'x');
|
|
|
|
$content =~ s/(\$\{.*\})/$1/gee;
|
|
my $out;
|
|
if (!open($out, '>', $oFile)) { ## no critic
|
|
Log3 $name, 3, "$name: set saveAsModule cannot create output file $oFile";
|
|
return "saveAsModule cannot create output file $oFile";
|
|
}
|
|
print $out $content;
|
|
close $out;
|
|
Log3 $name, 3, "$name: set saveAsModule created $oFile";
|
|
return "0";
|
|
}
|
|
|
|
|
|
###############################################################
|
|
# called via internal timer from
|
|
# logical device module with
|
|
# scan:name - name of logical device
|
|
#
|
|
sub ScanObjects {
|
|
my $param = shift;
|
|
my ($calltype,$name) = split(':',$param);
|
|
my $hash = $defs{$name}; # hash des logischen Devices, da GetUpdate aus dem logischen Modul per Timer gestartet wird
|
|
my $now = gettimeofday();
|
|
my $scanDelay = AttrVal($name, 'scanDelay', 1);
|
|
my $ioHash = GetIOHash($hash); # get ioHash to check for full queue. It has been checked in GetSetChecks
|
|
my $queue = $ioHash->{QUEUE};
|
|
my $qlen = ($ioHash->{QUEUE} ? scalar(@{$ioHash->{QUEUE}}) : 0);
|
|
my $qMax = AttrVal($ioHash->{NAME}, 'queueMax', AttrVal($name, 'queueMax', 100));
|
|
RemoveInternalTimer ("scan:$name");
|
|
if ($qlen && $qlen > $qMax / 2) {
|
|
InternalTimer($now+$scanDelay, \&Modbus::ScanObjects, "scan:$name", 0);
|
|
Log3 $name, 5, "$name: ScanObjects waits until queue gets smaller";
|
|
return;
|
|
}
|
|
if (defined($hash->{scanOAdr})) {
|
|
if ($hash->{scanOAdr} >= $hash->{scanOEnd}) {
|
|
delete $hash->{scanOAdr};
|
|
delete $hash->{scanOStart};
|
|
delete $hash->{scanOEnd};
|
|
delete $hash->{scanOType};
|
|
delete $hash->{scanOLen};
|
|
Log3 $name, 4, "$name: ScanObjects called from " . FhemCaller() . " ends at " .
|
|
($hash->{scanOType} // '') . ($hash->{scanOAdr} //'');
|
|
return; # end
|
|
}
|
|
$hash->{scanOAdr}++;
|
|
}
|
|
else {
|
|
$hash->{scanOAdr} = $hash->{scanOStart};
|
|
}
|
|
Log3 $name, 4, "$name: ScanObjects called from " . FhemCaller() . " will now try " .
|
|
($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);
|
|
return;
|
|
}
|
|
|
|
|
|
####################################################################
|
|
# called via internal timer from
|
|
# logical device module with
|
|
# scan:name - name of logical device
|
|
#
|
|
sub ScanIds {
|
|
my $param = shift;
|
|
my ($calltype,$name) = split(':',$param);
|
|
my $hash = $defs{$name}; # hash des logischen Devices, da GetUpdate aus dem logischen Modul per Timer gestartet wird
|
|
my $now = gettimeofday();
|
|
my $scanDelay = AttrVal($name, 'scanDelay', 1);
|
|
my $ioHash = GetIOHash($hash); # get ioHash to check for full queue. It has been checked in GetSetChecks
|
|
my $queue = $ioHash->{QUEUE};
|
|
my $qLen = ($ioHash->{QUEUE} ? scalar(@{$ioHash->{QUEUE}}) : 0);
|
|
my $qMax = AttrVal($ioHash->{NAME}, 'queueMax', AttrVal($name, 'queueMax', 100));
|
|
|
|
RemoveInternalTimer ("scan:$name");
|
|
if ($qLen && $qLen > $qMax) {
|
|
InternalTimer($now+$scanDelay, \&Modbus::ScanIds, "scan:$name", 0);
|
|
Log3 $name, 5, "$name: ScanIds waits until queue gets smaller";
|
|
return;
|
|
}
|
|
if ($hash->{scanId}) {
|
|
if ($hash->{scanId} >= $hash->{scanIdEnd}) {
|
|
delete $hash->{scanId};
|
|
delete $hash->{scanIdStart};
|
|
delete $hash->{scanIdEnd};
|
|
delete $hash->{scanOAdr};
|
|
delete $hash->{scanOLen};
|
|
delete $hash->{scanOType};
|
|
Log3 $name, 4, "$name: ScanId called from " . FhemCaller() . " will ends with id " .
|
|
(delete $hash->{scanId} // '') . ' ' . ($hash->{scanOType} // '') . ($hash->{scanOAdr} //'');
|
|
return; # end
|
|
}
|
|
$hash->{scanId}++;
|
|
}
|
|
else {
|
|
$hash->{scanId} = $hash->{scanIdStart};
|
|
}
|
|
Log3 $name, 4, "$name: ScanId called from " . FhemCaller() . " will now try id " .
|
|
($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);
|
|
return;
|
|
}
|
|
|
|
|
|
####################################################################################
|
|
# Notify for INITIALIZED -> Open defined physical / logical (tcp) device
|
|
# both for physical and logical tcp connected devices
|
|
#
|
|
# 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 registriert ist ...
|
|
sub NotifyFn {
|
|
my $hash = shift;
|
|
my $source = shift;
|
|
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|(MODIFIED $name)$|(DEFINED $name)$/} @{$events});
|
|
# DEFINED is not triggered if init is not done.
|
|
|
|
if (IsDisabled($name)) {
|
|
Log3 $name, 4, "$name: Notify / Init: device is disabled";
|
|
return;
|
|
}
|
|
if ($hash->{TYPE} eq 'Modbus' || $hash->{TCPConn}) { # physical or TCP -> call open (even for slave)
|
|
Log3 $name, 4, "$name: Notify / Init: opening connection";
|
|
DoOpen($hash, {CLOSEFIRST => 1}) if (!AttrVal($name, 'closeAfterResponse', 0) || $hash->{MODE} ne 'master');
|
|
# connection or listening socket for tcp slave
|
|
}
|
|
else { # logical dev and not TCP -> check for IO Device
|
|
delete $hash->{IODev}; # force call to setIODev / register and set state to opened
|
|
my $ioHash = GetIOHash($hash); # get / search and register at iodev
|
|
Log3 $name, 4, "$name: Notify / Init: " . ($ioHash ? "using $ioHash->{NAME}" : "no IODev") . " for communication";
|
|
}
|
|
if ($hash->{TYPE} ne 'Modbus' && $hash->{MODE} eq 'master') { # Mode Master
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'start');
|
|
}
|
|
elsif ($hash->{MODE} && $hash->{MODE} eq 'relay') { # Mode relay -> find / check relay device
|
|
my $reName = $hash->{RELAY};
|
|
my $reIOHash = GetRelayIO($hash);
|
|
Log3 $name, 4, "$name: Notify / Init: " . ($reIOHash ? "using $reIOHash->{NAME}" : "no device") . " as Modbus relay device (master)";
|
|
}
|
|
#Log3 $name, 3, '$name: _Notify done';
|
|
return;
|
|
}
|
|
|
|
|
|
##############################################################
|
|
# open connection
|
|
# $hash is physical or both (connection over TCP)
|
|
# called from set reconnect, Attr / LDAttr (disable),
|
|
# Notify (initialized, rereadcfg, |(MODIFIED $name)),
|
|
# Ready, ProcessRequestQueue and GetSetChecks
|
|
sub DoOpen {
|
|
my $hash = shift;
|
|
my $arg_ref = shift // {};
|
|
my $ready = $arg_ref->{READY} // 0;
|
|
my $name = $hash->{NAME};
|
|
my $now = gettimeofday();
|
|
my $caller = FhemCaller();
|
|
|
|
if ($hash->{DeviceName} eq 'none') {
|
|
Log3 $name, 5, "$name: open called from $caller, device is defined with none" if ($caller ne 'ReadyFn');
|
|
OpenCB($hash); # set state and start timers
|
|
}
|
|
elsif (!$hash->{TCPConn} && $hash->{TYPE} ne 'Modbus') { # only open physical devices or TCP
|
|
Log3 $name, 3, "$name: open called from $caller for logical device - this should not happen";
|
|
return;
|
|
}
|
|
elsif ($hash->{TCPChild}) {
|
|
Log3 $name, 3, "$name: open called for a TCP Child hash - this should not happen";
|
|
return;
|
|
}
|
|
elsif ($hash->{TCPServer}) {
|
|
# Modbus slave or relay over TCP connection -> open listening port
|
|
Log3 $name, 5, "$name: Open called for listening to a TCP connection";
|
|
if ($arg_ref->{CLOSEFIRST}) {
|
|
DoClose($hash); # close and set state in case open fails
|
|
}
|
|
my ($dest, $port) = split(/[:\s]+/, $hash->{DeviceName});
|
|
my $ret = TcpServer_Open($hash, $port, $dest);
|
|
if ($ret) {
|
|
Log3 $name, 3, "$name: TcpServerOpen returned $ret";
|
|
} else {
|
|
DevIo_setStates($hash, 'opened');
|
|
}
|
|
}
|
|
else { # normal case, physical device or TCP
|
|
my $timeOt = AttrVal($name, 'openTimeout', 3);
|
|
my $delay2 = AttrVal($name, 'nextOpenDelay2', 1);
|
|
my $nextOp = $hash->{NEXT_OPEN} // 0;
|
|
#Log3 $name, 5, "$name: Open nextOpenDelay = $delay2 ";
|
|
my $lastOp = $hash->{LASTOPEN}; # set when OpenDev is really called and cleared in DoClose
|
|
Log3 $name, 5, "$name: open called from $caller, busyOpenDev " .
|
|
($hash->{BUSY_OPENDEV} // 0) . ($nextOp ? ' NEXT_OPEN ' . FmtTimeMs($nextOp) : '') if (!$ready);
|
|
if ($hash->{BUSY_OPENDEV}) { # still waiting for callback to last open
|
|
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 - stop waiting for callback and reset the BUSY flag.";
|
|
$hash->{BUSY_OPENDEV} = 0;
|
|
}
|
|
if ($arg_ref->{CLOSEFIRST}) { # close first and already open
|
|
Log3 $name, 5, "$name: Open called for DevIo connection - closing first";
|
|
DoClose($hash); # close and set state in case open fails
|
|
delete $hash->{DevIoJustClosed}; # allow direct opening without further delay
|
|
}
|
|
elsif ($nextOp && ($nextOp > $now)) {
|
|
Log3 $name, 5, "$name: open ignored because DevIo has set NEXT_OPEN to $nextOp / " . FmtTimeMs($nextOp) .
|
|
" and now is $now / " . FmtTimeMs($now);
|
|
return;
|
|
}
|
|
if ($lastOp && $now < ($lastOp + $delay2)) { # ignore too many open requests within nextOpenDelay2
|
|
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);
|
|
return;
|
|
}
|
|
Log3 $name, 4, "$name: open trying to open connection to $hash->{DeviceName}" if (!$ready);
|
|
delete $hash->{NEXT_OPEN}; # already handled above
|
|
delete $hash->{DevIoJustClosed} if ($delay2); # allow direct opening without further delay
|
|
$hash->{IODev} = $hash if ($hash->{TCPConn}); # point back to self
|
|
$hash->{LASTOPEN} = $now;
|
|
$hash->{nextOpenDelay} = AttrVal($name, 'nextOpenDelay', 60);
|
|
$hash->{devioLoglevel} = (AttrVal($name, 'silentReconnect', 0) ? 4 : 3);
|
|
$hash->{TIMEOUT} = $timeOt;
|
|
if ($arg_ref->{FORCE}) {
|
|
DevIo_OpenDev($hash, $ready, 0); # standard synchronous open
|
|
OpenCB($hash); # do remaining steps (callback not specified in above call)
|
|
}
|
|
else {
|
|
$hash->{BUSY_OPENDEV} = 1;
|
|
DevIo_OpenDev($hash, $ready, 0, \&OpenCB); # async open
|
|
#DevIo_setStates($hash, 'opened'); # state will be set in callback
|
|
}
|
|
}
|
|
Profiler($hash, 'Idle'); # set category to book following time, can be Delay, Fhem, Idle, Read, Send or Wait
|
|
ResetExpect($hash);
|
|
|
|
# don't start queue timer until connection is actually open -> OpenCB
|
|
# StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0.5, silent => 0}); # process queue in case something is waiting but delay so open can call back
|
|
|
|
DropBuffer($hash);
|
|
delete $hash->{TIMEOUT};
|
|
return;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub OpenCB {
|
|
my $hash = shift;
|
|
my $msg = shift;
|
|
my $name = $hash->{NAME};
|
|
if ($msg) {
|
|
Log3 $name, 5, "$name: Open callback: $msg" if ($msg);
|
|
}
|
|
delete $hash->{BUSY_OPENDEV};
|
|
if (IsOpen($hash)) { # also works for 'none'
|
|
delete $hash->{TIMEOUTS} ;
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'start'); # set / change timer
|
|
DevIo_setStates($hash, 'opened');
|
|
}
|
|
# stop queue-Timer while disconnected and start it again with delay 0 here. ProcessRequestQueue will call open again if not open yet.
|
|
StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0, silent => 0});
|
|
return;
|
|
}
|
|
|
|
|
|
##################################################
|
|
# close connection
|
|
# $hash is physical or both (connection over TCP)
|
|
sub DoClose {
|
|
my $hash = shift;
|
|
my $arg_ref = shift // {};
|
|
my $noDelete = $arg_ref->{NODELETE} // 0;
|
|
my $keepQueue = $arg_ref->{KEEPQUEUE} // 0;
|
|
my $noState = $arg_ref->{NOSTATE} // 0;
|
|
my $name = $hash->{NAME};
|
|
|
|
if (!$hash->{TCPConn} && $hash->{TYPE} ne 'Modbus') {
|
|
Log3 $name, 3, "$name: close called from " . FhemCaller() .
|
|
' for logical device - this should not happen';
|
|
return;
|
|
}
|
|
|
|
Log3 $name, 5, "$name: Close called from " . FhemCaller() .
|
|
($keepQueue || $noDelete ? ' with ' : '') . ($keepQueue ? 'keepQueue' : '') .
|
|
($keepQueue && $noDelete ? ' and ' : '') . ($noDelete ? 'noDelete' : '');
|
|
|
|
delete $hash->{LASTOPEN}; # reset so next open will actually call OpenDev
|
|
if ($hash->{TCPChild}) { # this is a slave or relay connection hash
|
|
Log3 $name, 4, "$name: Close TCP server listening connection and delete hash";
|
|
TcpServer_Close($hash);
|
|
RemoveInternalTimer ("stimeout:$name");
|
|
if ($hash->{CHILDOF}){
|
|
my $parent = $hash->{CHILDOF};
|
|
delete $parent->{CONNECTHASH}{$name};
|
|
if ($parent->{LASTCONN} && $parent->{LASTCONN} eq $hash->{NAME}) {
|
|
Log3 $name, 5, "$name: Close is removing lastconn from parent device $parent->{NAME}";
|
|
delete $parent->{LASTCONN};
|
|
}
|
|
}
|
|
delete $hash->{CHILDOF}; # fix memory leak
|
|
delete $hash->{IODEV};
|
|
delete $hash->{REQUEST};
|
|
delete $hash->{RESPONSE};
|
|
delete $hash->{FRAME};
|
|
delete $hash->{READ};
|
|
delete $hash->{REMEMBER};
|
|
CommandDelete(undef, $name) if (!$noDelete); # delete tcp connection device unless called from undefFn which wants to delete later
|
|
return; # this hash is removed from %defs, attr ...
|
|
}
|
|
elsif ($hash->{TCPServer} && IsOpen($hash)) { # this is a slave or relay listening device
|
|
Log3 $name, 4, "$name: Close TCP server socket, now look for active connections";
|
|
TcpServer_Close($hash);
|
|
foreach my $conn (keys %{$hash->{CONNECTHASH}}) {
|
|
my $chash = $hash->{CONNECTHASH}{$conn};
|
|
TcpServer_Close($chash);
|
|
Log3 $chash->{NAME}, 4, "$chash->{NAME}: Close TCP server connection of parent $name";
|
|
RemoveInternalTimer ("stimeout:$chash->{NAME}");
|
|
CommandDelete(undef, $chash->{NAME}) if (!$noDelete);
|
|
}
|
|
delete $hash->{CONNECTHASH}; # delete hash containing the connection devices
|
|
Log3 $name, 5, "$name: Close deleted the CONNECTHASH";
|
|
}
|
|
elsif ($hash->{DeviceName} eq 'none') {
|
|
Log3 $name, 4, "$name: Simulate closing connection to none";
|
|
}
|
|
else {
|
|
Log3 $name, 4, "$name: Close connection with DevIo_CloseDev";
|
|
# close even if it was not open yet but on ready list (need to remove entry from readylist)
|
|
DevIo_CloseDev($hash);
|
|
}
|
|
GoToState($hash, 'disconnected') if (!$noState);
|
|
ResetExpect($hash);
|
|
DropBuffer($hash);
|
|
Profiler($hash, 'Idle'); # set category to book following time, can be Delay, Fhem, Idle, Read, Send or Wait
|
|
delete $hash->{IODev};
|
|
if($keepQueue) {
|
|
my $qlen = ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0);
|
|
Log3 $name, 4, "$name: DoClose keeps queue with len $qlen";
|
|
}
|
|
else {
|
|
StopQueueTimer($hash, {silent => 1});
|
|
delete $hash->{QUEUE};
|
|
}
|
|
RemoveInternalTimer ("timeout:$name"); # remove ResponseTimeout timer when connection is closed
|
|
delete $hash->{nextTimeout};
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################################
|
|
# ready fn for physical device
|
|
# and logical device (in case of tcp when logical device opens connection)
|
|
sub ReadyFn {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
|
|
if(DevIo_getState($hash) eq 'disconnected') {
|
|
if (IsDisabled($name)) {
|
|
Log3 $name, 3, "$name: ready called but $name is disabled - don't try to reconnect - call DoClose";
|
|
DoClose($hash); # state sollte schon disabled sein, macht aber nichts.
|
|
return;
|
|
}
|
|
DoOpen($hash, {READY => 1}); # reopen, dont call DevIoClose before reopening
|
|
return; # a return value only triggers direct read for windows - main loop select
|
|
}
|
|
# This is relevant for windows/USB only
|
|
my $po = $hash->{USBDev};
|
|
if ($po) {
|
|
my ($BlockingFlags, $InBytes, $OutBytes, $ErrorFlags) = $po->status;
|
|
return ($InBytes>0); # tell fhem.pl to read when we return if data available
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
############################################################################
|
|
# Called from the global loop, when the select for hash->{FD} reports data
|
|
# hash is hash of the physical device ( = logical device for TCP)
|
|
# this creates a new connection device
|
|
sub HandleServerConnection {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $chash = TcpServer_Accept($hash, $hash->{TYPE}); # accept with this module
|
|
return if(!$chash);
|
|
$chash->{CD}->flush();
|
|
Log3 $name, 4, "$name: HandleServerConnection accepted new TCP connection as device $chash->{NAME}";
|
|
$chash->{MODBUSID} = $hash->{MODBUSID};
|
|
$chash->{PROTOCOL} = $hash->{PROTOCOL};
|
|
$chash->{MODE} = $hash->{MODE};
|
|
$chash->{RELAY} = $hash->{RELAY}; # name of relay master device if this is a relay
|
|
$chash->{CHILDOF} = $hash; # point to parent device to get object definitions from there
|
|
$chash->{IODev} = $chash;
|
|
$chash->{TCPConn} = 1;
|
|
$chash->{TCPChild} = 1;
|
|
$chash->{DeviceName} = $hash->{DeviceName};
|
|
ResetExpect($chash);
|
|
# DoTrigger('global', "DEFINED $chash->{NAME}", 1) if($init_done);
|
|
# dotrigger is probably not helpful here. However it will not cause NotifyFn since the ecebt is not global ...
|
|
|
|
$attr{$chash->{NAME}}{verbose} = $attr{$name}{verbose}; # copy verbose attr from parent
|
|
$hash->{LASTCONN} = $chash->{NAME}; # point from parent device to last connection device
|
|
$hash->{CONNECTHASH}{$chash->{NAME}} = $chash;
|
|
weaken $hash->{CONNECTHASH}{$chash->{NAME}};
|
|
my $room = AttrVal($name, 'connectionsRoom', 'Connections');
|
|
if ($room !~ '[Nn]one') {
|
|
CommandAttr(undef, "$chash->{NAME} room $room"); # set room
|
|
}
|
|
my $to = gettimeofday() + DevInfo($hash, 'timing', 'serverTimeout', 120);
|
|
InternalTimer($to, \&Modbus::ServerTimeout, "stimeout:$chash->{NAME}", 0);
|
|
return;
|
|
}
|
|
|
|
|
|
##############################################
|
|
# check time gap between now and last read
|
|
# to clear old buffer or set expect to request
|
|
sub HandleGaps {
|
|
my $hash = shift; # physical device hash
|
|
my $name = $hash->{NAME};
|
|
my $now = gettimeofday();
|
|
|
|
# check time since last read / frameGap and remove old buffer if necessary
|
|
if (!$hash->{REMEMBER}{lrecv}) {
|
|
DropBuffer($hash, '(initialisation)');
|
|
return;
|
|
}
|
|
my $gap = ($now - $hash->{REMEMBER}{lrecv});
|
|
my $fTo = AttrVal($name, 'frameGap', 1.5);
|
|
if ($gap > $fTo && $hash->{READ}{BUFFER}) {
|
|
DropBuffer($hash, 'after gap of ' . sprintf ('%.2f', $gap) . ' secs.');
|
|
}
|
|
# also check if EXPECT should be reset
|
|
# Mode slave or relay: (receiving side): if we reading something after a long delay it has to be a new request
|
|
# Mode passive: use DevInfo($hash, 'timing', 'timeout', 2) as timout to switch from response to request
|
|
# Mode master: is only reading responses, anything else is an error. Nothing to be done here
|
|
my $to = DevInfo($hash, 'timing', 'timeout', 2);
|
|
if ($gap > $to) {
|
|
if ($hash->{MODE} ne 'master') {
|
|
ResetExpect($hash, 'read gap is more than response timeout');
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################################
|
|
# Called from the global loop, when the select for hash->{FD} reports data
|
|
# hash is hash of the physical device ( = logical device for TCP)
|
|
sub ReadFn {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $now = gettimeofday();
|
|
my ($buf, $ret);
|
|
|
|
# first get data from socket / serial device into buffer
|
|
if ($hash->{DeviceName} eq 'none') { # simulate receiving
|
|
if ($hash->{TestInput}) {
|
|
$buf = $hash->{TestInput};
|
|
delete $hash->{TestInput};
|
|
}
|
|
}
|
|
elsif($hash->{TCPServer} || $hash->{TCPChild}) {
|
|
if($hash->{SERVERSOCKET}) { # this is a TCP server / modbus slave device
|
|
HandleServerConnection($hash); # accept and create a child device hash for the connection
|
|
return;
|
|
}
|
|
# TCP client device connection device hash
|
|
Profiler($hash, 'Read'); # read from TCP socket
|
|
$ret = sysread($hash->{CD}, $buf, 256) if ($hash->{CD});
|
|
if(!defined($ret) || $ret <= 0) { # connection closed
|
|
Log3 $name, 3, "$name: read from TCP server connection got null -> closing";
|
|
CommandDelete(undef, $name);
|
|
return;
|
|
}
|
|
my $to = $now + DevInfo($hash, 'timing', 'serverTimeout', 120);
|
|
my $tA = DevInfo($hash, 'timing', 'serverTimeoutAbs', 0);
|
|
if (!$tA) {
|
|
RemoveInternalTimer ("stimeout:$name");
|
|
InternalTimer($to, \&Modbus::ServerTimeout, "stimeout:$name", 0);
|
|
}
|
|
}
|
|
else {
|
|
Profiler($hash, 'Read');
|
|
$buf = DevIo_SimpleRead($hash); # read from serial connection
|
|
return if(!defined($buf));
|
|
}
|
|
|
|
HandleGaps($hash); # check timing / frameGap and remove old buffer if necessary
|
|
$hash->{READ}{BUFFER} .= $buf; # now add new data to buffer
|
|
$hash->{REMEMBER}{lrecv} = $now; # rember time for physical side
|
|
Log3 $name, 5, "$name: readFn buffer: " . ShowBuffer($hash) . " mode $hash->{MODE}, expect $hash->{EXPECT}";
|
|
delete $hash->{FRAME}; # remove old stuff
|
|
|
|
if (!$hash->{MODE} || !$hash->{PROTOCOL}) { # MODE and PROTOCOL keys are taken from logical device in NOTIFY
|
|
DropBuffer($hash, 'mode or protocol not set (probably no active logical device registered)');
|
|
return; # EXPECT doesn't matter, Logging frame not needed
|
|
}
|
|
|
|
for (;;) {
|
|
# parse frame start, create $hash->{FRAME} with {MODBUSID}, {FCODE}, {DATA}
|
|
# and for TCP also $hash->{FRAME}{PDULEXP} and $hash->{FRAME}{TID}
|
|
if (!ParseFrameStart($hash)) { # not enough data / no frame match
|
|
Log3 $name, 5, "$name: readFn did not see a valid $hash->{PROTOCOL} frame start yet, wait for more data";
|
|
return;
|
|
}
|
|
my $frame = $hash->{FRAME}; # is set after calling ParseFrameStart
|
|
|
|
|
|
# only for testing
|
|
my $attrsName = $name;
|
|
if ($hash->{CHILDOF}) {
|
|
$attrsName = $hash->{CHILDOF}{NAME};
|
|
}
|
|
my $requestDelay = AttrVal ($attrsName, 'requestDelay', 0);
|
|
#Log3 $name, 3, "$name: requestDelay is $requestDelay";
|
|
if ($requestDelay) {
|
|
if ($hash->{LastRequest}) {
|
|
if ($hash->{LastRequest} + $requestDelay > $now) {
|
|
Log3 $name, 3, "$name: requestDelay causes request to be ignored";
|
|
DropFrame($hash);
|
|
return;
|
|
}
|
|
}
|
|
$hash->{LastRequest} = $now;
|
|
}
|
|
|
|
# EXPECT exists on io dev. Special case for relays:
|
|
# there are two io devs. receiving side and forwarding side.
|
|
# read can be called when a new request comes in on receiving side (mode relay)
|
|
# or when a response comes in at forwarding side (mode master)
|
|
|
|
if ($hash->{EXPECT} eq 'request') { # --- REQUEST ---
|
|
return if (!HandleRequest($hash)) ; # check for valid PDU, parse, return if frame not complete (yet)
|
|
# ERROR is only set by Checksum Check or unsupported fCode here.
|
|
if ($hash->{FRAME}{CHECKSUMERROR} && $hash->{MODE} eq 'passive') {
|
|
Log3 $name, 5, "$name: no valid request -> try interpretation as response instead";
|
|
delete $hash->{REQUEST}; # this one would be invalid anyway
|
|
delete $hash->{FRAME}{ERROR};
|
|
return if (!HandleResponse($hash)); # try as response PDU, CRC, parse, log, return if frame not complete (yet)
|
|
}
|
|
DropFrame($hash); # drop $hash->{FRAME} and the relevant part of $hash->{READ}{BUFFER}
|
|
}
|
|
elsif ($hash->{EXPECT} eq 'response') { # --- RESPONSE ---
|
|
return if (!HandleResponse($hash)); # check PDU, CRC, parse, log, return if frame not complete (yet)
|
|
if ($hash->{FRAME}{CHECKSUMERROR} && $hash->{MODE} ne 'master') {
|
|
Log3 $name, 5, "$name: no valid response -> try interpretation as request instead";
|
|
delete $hash->{FRAME}{ERROR};
|
|
return if (!HandleRequest($hash)); # try as response PDU, CRC, parse, log, return if frame not complete (yet)
|
|
}
|
|
DropFrame($hash); # drop $hash->{FRAME} and the relevant part of $hash->{READ}{BUFFER}
|
|
}
|
|
elsif ($hash->{EXPECT} eq 'idle') { # master is doing nothing but maybe there is an illegal other master?
|
|
Log3 $name, 3, "$name: readfn got data while EXPECT was set to idle: " . ShowBuffer($hash);
|
|
if ($hash->{MODE} eq 'master') {
|
|
DropBuffer($hash);
|
|
return;
|
|
}
|
|
ResetExpect($hash); # when we are not master we should not be idle
|
|
}
|
|
else { # this should not be possible
|
|
Log3 $name, 3, "$name: internal error, illegal EXPECT value " . $hash->{EXPECT} // 'undefined';
|
|
ResetExpect($hash);
|
|
}
|
|
Log3 $name, 5, "$name: readFn end buffer: " . ShowBuffer($hash) . " mode $hash->{MODE}, expect $hash->{EXPECT}";
|
|
return if (!$hash->{READ}{BUFFER}); # return if no more data, else parse on
|
|
} # next round in loop
|
|
return; # never reached
|
|
}
|
|
|
|
|
|
################################################################################
|
|
# Called from get / set to get a direct answer - only for Fhem as master.
|
|
# Returns an error message or undef if success.
|
|
# queue timer is started after calling ReadAnswer
|
|
sub ReadAnswer {
|
|
my $hash = shift; # called with physical io device hash
|
|
my $name = $hash->{NAME};
|
|
my $logHash = $hash->{REQUEST}{MASTERHASH}; # logical device that sent last request, stored by ProcessRequestQueue, checked in loop ...
|
|
my $timeout = DevInfo($logHash, 'timing', 'timeout', 2);
|
|
my $now = gettimeofday();
|
|
my $timeRest;
|
|
my $rin = '';
|
|
my $buf;
|
|
my $msg = '';
|
|
|
|
Log3 $name, 5, "$name: ReadAnswer called from " . FhemCaller();
|
|
|
|
# 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.
|
|
|
|
RemoveInternalTimer ("timeout:$name"); # remove potential existing ResponseTimeout timer, timeout is handled in here now
|
|
Profiler($hash, 'Read');
|
|
|
|
READLOOP:
|
|
for (;;) {
|
|
|
|
# get timeout. In case ReadAnswer is called after a delay or to take over an async read,
|
|
# only wait for remaining time
|
|
$timeRest = $hash->{nextTimeout} - gettimeofday();
|
|
$timeout = $timeRest if ($timeRest < $timeout);
|
|
Log3 $name, 5, "$name: ReadAnswer remaining timeout is $timeout";
|
|
|
|
if ($timeout <= 0 || ($hash->{DeviceName} eq 'none' && !$hash->{TestInput})) {
|
|
last READLOOP; # Timeout - will be logged after the loop
|
|
}
|
|
if (!$hash->{REQUEST}{MASTERHASH}) {
|
|
Log3 $name, 5, "$name: ReadAnswer misses MASTERHASH and returns";
|
|
$msg = 'ReadAnswer called but MASTERHASH disappeared';
|
|
last READLOOP;
|
|
}
|
|
if ($hash->{DeviceName} eq 'none') { # simulate receiving
|
|
$buf = $hash->{TestInput};
|
|
delete $hash->{TestInput};
|
|
}
|
|
elsif ($^O =~ m/Win/ && $hash->{USBDev}) {
|
|
$hash->{USBDev}->read_const_time($timeout*1000); # set timeout (ms)
|
|
$buf = $hash->{USBDev}->read(999);
|
|
last READLOOP if(length($buf) == 0);
|
|
}
|
|
else {
|
|
if (!$hash->{FD}) {
|
|
$msg = "ReadAnswer called but Device $name lost connection";
|
|
last READLOOP; # exit loop and report error
|
|
}
|
|
vec($rin, $hash->{FD}, 1) = 1; # setze entsprechendes Bit in rin
|
|
my $nfound = select($rin, undef, undef, $timeout);
|
|
last READLOOP if ($nfound == 0); # Timeout - will be logged after the loop
|
|
if ($nfound < 0) {
|
|
next if ($! == EAGAIN() || $! == EINTR() || $! == 0);
|
|
$msg = 'Error in ReadAnswer: $!';
|
|
Log3 $name, 3, "$name: ReadAnswer sets device to disconnected";
|
|
DevIo_Disconnected($hash); # close, set state but put back on readyfnlist for reopening
|
|
last READLOOP;
|
|
}
|
|
$buf = DevIo_SimpleRead($hash);
|
|
if (!defined($buf)) {
|
|
$msg = 'ReadAnswer got no data';
|
|
last READLOOP
|
|
}
|
|
}
|
|
if ($buf) {
|
|
$now = gettimeofday();
|
|
$hash->{READ}{BUFFER} .= $buf;
|
|
$hash->{REMEMBER}{lrecv} = $now;
|
|
$logHash->{REMEMBER}{lrecv} = $now;
|
|
Log3 $name, 5, "$name: ReadAnswer got: " . ShowBuffer($hash);
|
|
}
|
|
|
|
delete $hash->{FRAME}; # remove old stuff
|
|
# create $hash->{FRAME}{MODBUSID}, $hash->{FRAME}{FCODE}, $hash->{FRAME}{DATA}
|
|
# and for TCP also $hash->{FRAME}{PDULEXP} and $hash->{FRAME}{TID}
|
|
if (!ParseFrameStart($hash)) { # not enough data / no frame match
|
|
Log3 $name, 5, "$name: ReadAnswer got no valid frame after HandleFrameStart, wait for more data";
|
|
next READLOOP;
|
|
}
|
|
my $frame = $hash->{FRAME}; # is set after HandleFrameStart
|
|
if (HandleResponse($hash)) { # end of parsing. Error or valid frame, cleans up and sets Profiler to 'Idle' if done
|
|
DropFrame($hash); # drop $hash->{FRAME} and the relevant part of $hash->{READ}{BUFFER}
|
|
if ($hash->{RESPONSE}{ERRCODE}) {
|
|
my $ret = "Error code $hash->{RESPONSE}{ERRCODE} / $errCodes{$hash->{RESPONSE}{ERRCODE}}";
|
|
Log3 $name, 5, "$name: ReadAnswer got $ret";
|
|
return $ret;
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
# READLOOP exited because of error / timeout
|
|
$timeRest = $hash->{nextTimeout} - gettimeofday(); # timeout?
|
|
if ($timeRest <= 0) {
|
|
$msg .= ($msg ? ', ' : '') . 'Timeout in Readanswer';
|
|
Statistics($hash, 'Timeouts');
|
|
CountTimeouts ($hash);
|
|
}
|
|
|
|
LogFrame($hash, $msg, AttrVal($name, 'timeoutLogLevel', 3));
|
|
$hash->{EXPECT} = 'idle';
|
|
Profiler($hash, 'Idle');
|
|
DropFrame($hash); # drop $hash->{FRAME} and the relevant part of $hash->{READ}{BUFFER}
|
|
delete $hash->{nextTimeout};
|
|
delete $hash->{REQUEST};
|
|
if (AttrVal($name, 'closeAfterResponse', 0) == 2) {
|
|
StartQueueTimer($hash, \&Modbus::ProcessRequestQueue); # normal delay
|
|
}
|
|
else {
|
|
StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0}); # call processRequestQueue at next possibility if appropriate
|
|
}
|
|
return $msg;
|
|
}
|
|
|
|
|
|
##########################################################################
|
|
# check if expected start byte comes later (ASCII or D for RTU)
|
|
# and skip garbage until this position
|
|
# startByte is always ':'' for ASCII or the Request Id for RTU Responses
|
|
# called from parseFrameStart
|
|
sub SkipGarbageCheck {
|
|
my $hash = shift; # io device hash
|
|
my $startByte = shift; # optional byte to look for (: for Modbus ASCII, known ID for RTU)
|
|
my $name = $hash->{NAME};
|
|
my $skipMode = AttrVal ($name, 'skipGarbage', 0);
|
|
my $start = 0;
|
|
|
|
if ($hash->{MODE} ne 'master' && $hash->{PROTOCOL} ne 'ASCII' && !$skipMode) {
|
|
# always check for start byte when protocol is ASCII or mode is Master.
|
|
# otherwise depend on the skipMode attribute
|
|
return $hash->{READ}{BUFFER};
|
|
}
|
|
use bytes;
|
|
|
|
if (!$startByte && $hash->{PROTOCOL} eq 'RTU') {
|
|
# check for a possible ID of one of the logical devices
|
|
Log3 $name, 5, "$name: SkipGarbageCheck special feature without given id";
|
|
$start = length($hash->{READ}{BUFFER}); # default if no start found -> drop everything
|
|
BUFLOOP:
|
|
for my $pos (0..length($hash->{READ}{BUFFER})-1) {
|
|
my $id = unpack('C', substr($hash->{READ}{BUFFER}, $pos, 1));
|
|
DEVLOOP:
|
|
for my $ld (keys %{$hash->{defptr}}) { # for each registered logical device
|
|
if ($defs{$ld} && $defs{$ld}{MODBUSID} == $id) {
|
|
$start = $pos if ($pos < $start);
|
|
Log3 $name, 4, "$name: SkipGarbageCheck found potential id $id at pos $start";
|
|
}
|
|
}
|
|
last BUFLOOP if ($start < length($hash->{READ}{BUFFER})); # exit at first pos found
|
|
}
|
|
} elsif ($startByte) {
|
|
#Log3 $name, 4, "$name: SkipGarbageCheck looking for start byte " . unpack ('H*', $startByte).
|
|
# " protocol is $hash->{PROTOCOL}, mode is $hash->{MODE}";
|
|
$start = index($hash->{READ}{BUFFER}, $startByte);
|
|
}
|
|
|
|
if ($start > 0) {
|
|
my $skip = substr($hash->{READ}{BUFFER}, 0, $start);
|
|
$hash->{READ}{BUFFER} = substr($hash->{READ}{BUFFER}, $start);
|
|
Log3 $name, 4, "$name: SkipGarbageCheck skipped $start bytes (" .
|
|
ShowBuffer($hash, $skip) . ' rest ' . ShowBuffer($hash) . ')';
|
|
}
|
|
return $hash->{READ}{BUFFER};
|
|
}
|
|
|
|
|
|
#####################################################
|
|
# parse the beginning of a request or response frame
|
|
# called from ReadFn and ReadAnswer with physical hash
|
|
sub ParseFrameStart {
|
|
my $hash = shift; # the device hash of the io device
|
|
my $name = $hash->{NAME};
|
|
my $proto = $hash->{PROTOCOL};
|
|
my $frameString = $hash->{READ}{BUFFER};
|
|
my ($id, $fCode, $data, $tid, $dlen, $pdu, $null);
|
|
my $expectId;
|
|
$expectId = $hash->{REQUEST}{MODBUSID} if ($hash->{REQUEST} && $hash->{REQUEST}{MODBUSID});
|
|
# $hash->{REQUEST} is removed in HandleRequest when the last request was not valid (CRC)
|
|
|
|
Log3 $name, 5, "$name: ParseFrameStart called from " . FhemCaller() .
|
|
($expectId ? " protocol $proto expecting id $expectId" : '');
|
|
use bytes;
|
|
if ($proto eq 'RTU') {
|
|
$frameString = SkipGarbageCheck($hash, ($expectId ? pack('C', $expectId) : undef)); # pass undef if no $expectId
|
|
return if ($frameString !~ /(..)(.*)(..)/s); # (id fCode) (data) (crc), return if incomplete. fc17 has no data ...
|
|
($id, $fCode) = unpack ('CC', $1);
|
|
$data = $2;
|
|
}
|
|
elsif ($proto eq 'ASCII') {
|
|
$frameString = SkipGarbageCheck($hash, ':'); # always do this for ASCII
|
|
return if ($frameString !~ /:(..)(..)(.+)(..)\r\n/); # : (id) (fCode) (data) (lrc) \r\n, return if incomplete
|
|
local $SIG{__WARN__} = sub { Log3 $name, 3, "$name: reading hex data from ASCII in ParseFrameStart created warning: @_"; };
|
|
$id = hex($1);
|
|
$fCode = hex($2);
|
|
$data = pack('H*', $3);
|
|
}
|
|
elsif ($proto eq 'TCP') {
|
|
return if (length($frameString) < 8); # return if incomplete
|
|
($tid, $null, $dlen, $id, $pdu) = unpack ('nnnCa*', $frameString);
|
|
($fCode, $data) = unpack ('Ca*', $pdu);
|
|
$hash->{FRAME}{TID} = $tid;
|
|
$hash->{FRAME}{PDULEXP} = $dlen-1; # data length without id
|
|
#Log3 $name, 5, "$name: ParseFrameStart for TCP extracted tid $tid, null, dlen $dlen, id $id and pdu " . unpack ('H*', $pdu);
|
|
}
|
|
$hash->{FRAME}{MODBUSID} = $id;
|
|
$hash->{FRAME}{FCODE} = $fCode;
|
|
$hash->{FRAME}{DATA} = $data;
|
|
Log3 $name, 4, "$name: ParseFrameStart ($proto, $hash->{MODE}) extracted id $id, fCode $fCode" .
|
|
($hash->{FRAME}{TID} ? ', tid ' . $hash->{FRAME}{TID} : '') .
|
|
($dlen ? ', dlen ' . $dlen : '') .
|
|
' and potential data ' . unpack ('H*', $data);
|
|
return 1;
|
|
}
|
|
|
|
|
|
#############################################################################
|
|
# called after ParseFrameStart by read / readAnswer if we are master
|
|
# check that response fits our request_method, call parseResponse
|
|
# validate checksums, call ParseDataString to set readings
|
|
# return undef if need more data or 1 if final success or error.
|
|
# cleans up at the end.
|
|
#
|
|
# note that we could be the master part of a relay and the request
|
|
# might have come in through a TCP slave part of the relay
|
|
# so data in the response might need to be interpreted in the context
|
|
# of a TCP slave parent device ...
|
|
#############################################################################
|
|
sub HandleResponse {
|
|
my $hash = shift; # the physical io device hash
|
|
my $name = $hash->{NAME};
|
|
my $frame = $hash->{FRAME};
|
|
my $request = $hash->{REQUEST}; # the request for this response
|
|
my $masterHash; # the logical (master) device - for timing / attrs
|
|
my $relayHash; # the relay parent device of the request
|
|
|
|
Log3 $name, 5, "$name: HandleResponse called from " . FhemCaller();
|
|
|
|
# idea: how to cancel a request but still remember that is was canceled when we send a new one?
|
|
# do we need a list of sent requests at io dev?
|
|
|
|
if ($request) {
|
|
$masterHash = $request->{MASTERHASH};
|
|
$masterHash = GetLogHash($hash, $frame->{MODBUSID}) if (!$masterHash); # e.g. for passive mode
|
|
$relayHash = ($request->{RELAYHASH}{CHILDOF} ? $request->{RELAYHASH}{CHILDOF} : $request->{RELAYHASH}) if ($request->{RELAYHASH});
|
|
if ($request->{FRAME} && $hash->{READ}{BUFFER} eq $request->{FRAME} && $frame->{FCODE} < 5) { # might be ok.
|
|
Log3 $name, 3, "$name: HandleResponse read the same data sent before - looks like an echo!";
|
|
}
|
|
if ($frame->{MODBUSID} != $request->{MODBUSID} && $request->{MODBUSID} != 0) { # definitely wrong.
|
|
AddFrameError($frame, "Modbus ID $frame->{MODBUSID} of response does not match request ID $request->{MODBUSID}");
|
|
}
|
|
if ($hash->{PROTOCOL} eq 'TCP' && $request->{TID} != $frame->{TID}) { # wrong. dont need to wait for another answer...
|
|
AddFrameError($frame, "TID $frame->{TID} in Modbus TCP response does not match request TID $request->{TID}");
|
|
}
|
|
if ($request->{FCODE} != $frame->{FCODE} && $frame->{FCODE} < 128 && $request->{FCODE} != 999) {
|
|
AddFrameError($frame, "Function code $frame->{FCODE} in Modbus response does not match request function code $request->{FCODE}");
|
|
}
|
|
}
|
|
else {
|
|
Log3 $name, 4, "$name: HandleResponse got data but we don't have a request";
|
|
$masterHash = GetLogHash($hash, $frame->{MODBUSID});
|
|
}
|
|
|
|
$hash->{REMEMBER}{lid} = $frame->{MODBUSID}; # device id we last heard from
|
|
if ($masterHash) {
|
|
$masterHash->{REMEMBER}{lrecv} = gettimeofday();
|
|
$hash->{REMEMBER}{lname} = $masterHash->{NAME}; # logical device name
|
|
}
|
|
Log3 $name, 5, "$name: HandleResponse is now creating response hash, masterHash is "
|
|
. ($masterHash ? $masterHash : 'undef');
|
|
my %responseData; # create new response structure
|
|
my $response = \%responseData;
|
|
if ($request) {
|
|
if ($masterHash) {
|
|
$response->{MASTERHASH} = $masterHash;
|
|
weaken $response->{MASTERHASH};
|
|
}
|
|
if ($request->{RELAYHASH}) { # not $relayHash! (which would be the parent device if tcp)
|
|
$response->{RELAYHASH} = $request->{RELAYHASH}; # the relay connection device
|
|
weaken $response->{RELAYHASH};
|
|
}
|
|
} # if no request known, we will skip most of the part below
|
|
Log3 $name, 5, "$name: HandleResponse is now calling ParseResponse, masterHash is "
|
|
. ($masterHash ? $masterHash : 'undef');
|
|
# parse response and fill response hash, returns undef if incomplete
|
|
# also $frame->{PDULEXP} will be set now if not already earlier.
|
|
return if (!ParseResponse($hash, $response, $masterHash)); # frame not complete - continue reading
|
|
$hash->{RESPONSE} = $response; # save in receiving io hash for later use
|
|
|
|
delete $hash->{nextTimeout}; # at least we didn't have a timeout now. Remove it to allow new requests while parsing
|
|
delete $hash->{TIMEOUTS}; # clear timeout counter
|
|
delete $hash->{RETRY}; # retry counter (if retry after timeout is wanted)
|
|
|
|
if ($request && !$frame->{ERROR}) { # only parse / relay if we know the request and no frame error - otherwise fall through and finish parsing
|
|
Profiler($hash, 'Fhem');
|
|
my $rErrC = $response->{ERRCODE};
|
|
if ($rErrC) { # valid error message response
|
|
if ($masterHash) { # be quiet if no logical device hash (not our responsibility)
|
|
my $errCodeT = $errCodes{$rErrC};
|
|
my $errString = unpack ('H*', pack('C', $response->{FCODE}))
|
|
. " / $rErrC" . ($errCodeT ? ", $errCodeT" : '');
|
|
Log3 $name, 4, "$name: HandleResponse got response with error code $errString";
|
|
if (AttrVal($name, "showError", 0)) {
|
|
readingsSingleUpdate($hash, "LAST_ERROR", "slave replied with error code $errString", 1);
|
|
}
|
|
}
|
|
}
|
|
else { # no error response, now check if we can parse data
|
|
if ($fcMap{$frame->{FCODE}}{objReturn} || exists $response->{VALUES}) { # data to parse?
|
|
Log3 $name, 5, "$name: now parsing response data objects, master is " .
|
|
($masterHash ? $masterHash->{NAME} : 'undefined') . " relay is " .
|
|
($relayHash ? $relayHash->{NAME} : 'undefined');
|
|
ParseDataString($masterHash, $response) if ($masterHash);
|
|
ParseDataString($relayHash, $response) if ($relayHash);
|
|
} elsif ($request->{FCODE} == 999) {
|
|
my $hexData = unpack ('H*', $frame->{DATA});
|
|
my $hexFC = sprintf ('%1X', $frame->{FCODE});
|
|
$hexData = ($hexData ? $hexData : 'no data');
|
|
Log3 $name, 4, "$name: got reply to raw request: fCode $hexFC, $hexData";
|
|
readingsSingleUpdate($masterHash, "rawResponse-$hexFC", $hexData, 1);
|
|
}
|
|
}
|
|
RelayResponse($hash, $request, $response) if ($relayHash && $request); # add to {ERROR} if relay device is unavailable
|
|
}
|
|
if ($frame->{ERROR}) {
|
|
LogFrame($hash, 'HandleResponse error', 4);
|
|
if (AttrVal($name, "showError", 0)) {
|
|
readingsSingleUpdate($hash, "LAST_ERROR", $frame->{ERROR}, 1);
|
|
}
|
|
}
|
|
else {
|
|
LogFrame($hash, 'HandleResponse done', 4);
|
|
}
|
|
|
|
Statistics($hash, 'Timeouts', 0); # damit bei Bedarf das Reading gesetzt wird
|
|
ResetExpect($hash); # for master back to 'idle', otherwise back to 'request'
|
|
Profiler($hash, 'Idle');
|
|
delete $hash->{REQUEST};
|
|
delete $hash->{RESPONSE};
|
|
RemoveInternalTimer ("timeout:$name"); # remove ResponseTimeout timer now that Response has arrived
|
|
|
|
if ($hash->{MODE} eq 'master') { # close after last response in queue
|
|
if (AttrVal($name, 'closeAfterResponse', 0) && ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0) == 0) {
|
|
Log3 $name, 4, "$name: HandleResponse will close because closeAfterResponse is set and queue is empty";
|
|
DoClose($hash);
|
|
return 1;
|
|
}
|
|
elsif (AttrVal($name, 'closeAfterResponse', 0) == 2) { # close after each response regardless of remaining queue entries
|
|
Log3 $name, 4, "$name: HandleResponse will close because closeAfterResponse is 2";
|
|
DoClose($hash, {KEEPQUEUE => 1});
|
|
StopQueueTimer($hash); # restart with full queue delay
|
|
StartQueueTimer($hash, \&Modbus::ProcessRequestQueue);
|
|
return 1;
|
|
}
|
|
}
|
|
StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0}); # set timer to call processRequestQueue asap
|
|
return 1; # error or not, parsing is done.
|
|
}
|
|
|
|
|
|
##################################################################################
|
|
# create hash with information about custom function codes and other information
|
|
# from dev- attrs for an individual master / slave and separate for requests / responses
|
|
# called with the logical device hash, function code and pduType (Request / Response)
|
|
sub createDevInfoCache {
|
|
my $hash = shift; # the logical master device to access parsing attrs
|
|
my $fCode = shift;
|
|
my $pduType = shift; # Request or Response for looking up attrs
|
|
my $name = $hash->{NAME}; # the name of the logical device
|
|
my $cFc = 'fc' . $fCode . $pduType; # key for potential custom function code
|
|
my $unpack = DevInfo($hash, $cFc, 'unpack'); # unpack for custom fcode?
|
|
my @fNames = split (', ', DevInfo($hash, $cFc, 'fieldList'));
|
|
|
|
my %di;
|
|
$di{UNPACK} = $unpack;
|
|
$di{FNAMES} = \@fNames;
|
|
$di{EXPRS} = {};
|
|
|
|
Log3 $name, 5, "$name: createDevInfoCache fc $fCode called";
|
|
|
|
my %temp;
|
|
foreach my $fld (@pduFields) { # for all potential fields
|
|
my $expr = DevInfo($hash, $cFc, 'fieldExpr-' . $fld); # check if there is an expr defined
|
|
if ($expr) {
|
|
$di{EXPRS}{$fld} = $expr; # put exprs temporarily in $di{EXTRA}
|
|
Log3 $name, 5, "$name: createDevInfoCache fc $fCode field $fld expr $expr";
|
|
$temp{$fld} = 1;
|
|
}
|
|
}
|
|
foreach my $fld (@fNames) { # for all fields unsed for unpacking
|
|
delete $temp{$fld}; # remove from temp hash
|
|
Log3 $name, 5, "$name: createDevInfoCache fc $fCode remove field $fld from EXTRAS";
|
|
}
|
|
my @extras = keys %temp;
|
|
$di{EXTRAS} = \@extras;
|
|
|
|
# brokenFCx could be set for masters that should interpret wrong responses from a special slave.
|
|
# today no more such attrs should be introduced but individual dev-fcxRespnse attr should be used instead
|
|
if ($fCode == 3 && $pduType eq 'Response' && DevInfo($hash, 'h', 'brokenFC3')) { # devices that respond with wrong pdu: fCode, adr, registers
|
|
Log3 $name, 5, "$name: createDevInfoCache fc $fCode modifies definitions for Broken FC3";
|
|
$di{TYPE} = 'h';
|
|
$di{UNPACK} = 'na*';
|
|
$di{FNAMES} = ['ADR', 'VALUES']; # fields to be unpacked
|
|
$di{EXTRAS} = ['LEN', 'PDULEXP']; # more fields to be set, array also defines order of evaluation!
|
|
#$di{EXPRS}{VALUES} = 'length($val) > $pduHash->{LEN}*2 ? substr($val, 0, $pduHash->{LEN}*2) : $val'; # not really necessary
|
|
$di{EXPRS}{LEN} = '$val * 2'; # brokenFC3 should only be set for a master and this will only be used for interpreting responses
|
|
$di{EXPRS}{PDULEXP} = '$pduHash->{LEN} + 3'; # 1 Byte fCode + 2 Byte adr + 2 bytes per register (after LEN Expression)
|
|
}
|
|
if ($fCode == 2 && $pduType eq 'Response' && DevInfo($hash, 'd', 'brokenFC2') eq 'doepke') {
|
|
Log3 $name, 5, "$name: createDevInfoCache fc $fCode modifies definitions for Broken FC2 doepke";
|
|
$di{TYPE} = 'd';
|
|
$di{UNPACK} = 'Ca*';
|
|
$di{FNAMES} = ['LEN', 'VALUES']; # fields to be unpacked
|
|
$di{EXTRAS} = ['PDULEXP']; # more fields to be set, array also defines order of evaluation!
|
|
$di{EXPRS}{PDULEXP} = '$pduHash->{LEN} + 2';
|
|
$di{EXPRS}{VALUES} = 'substr($val, 1, 1)'; # drop first byte
|
|
}
|
|
if ($fCode == 5 && $pduType eq 'Response' && DevInfo($hash, 'd', 'brokenFC5')) {
|
|
Log3 $name, 5, "$name: createDevInfoCache fc $fCode modifies definitions for Broken FC5";
|
|
$di{TYPE} = 'c'; # write single coil
|
|
$di{UNPACK} = 'nH4'; # 2 bytes adr, 2 bytes values
|
|
$di{FNAMES} = ['ADR', 'VALUES']; # fields to be unpacked
|
|
$di{EXTRAS} = ['PDULEXP', 'LEN']; # more fields to be set, array also defines order of evaluation!
|
|
$di{EXPRS}{PDULEXP} = '5';
|
|
$di{EXPRS}{VALUES} = 'pack ("c", ($val eq "0000" ? 0 : 1)'; # normally ff00 is 1 and 0000 is 0. Broken devices might use 0001 and 0000
|
|
$di{EXPRS}{LEN} = '1';
|
|
}
|
|
$hash->{DICACHE}{$fCode} = \%di;
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
##################################################################################
|
|
# parse function code PDUs
|
|
# called with the logical device hash
|
|
# otherwise no information about custiom fc definitions exist
|
|
# could be used tp parse standard fc as well but this would only slow down things
|
|
# so this function is only used for custom fcs
|
|
sub parsePDU {
|
|
my $hash = shift; # the logical master device to access parsing attrs
|
|
my $frame = shift;
|
|
my $pduHash = shift; # pdu structure to be filled, already contains adr/len/operation/masterhash/relayhash from request
|
|
my $pduType = shift; # Request or Response for looking up attrs
|
|
my $name = $hash->{NAME}; # the name of the logical device
|
|
my $fCode = $frame->{FCODE}; # filled in handleFrameStart
|
|
my $data = $frame->{DATA};
|
|
|
|
createDevInfoCache($hash, $fCode, $pduType) if (!$hash->{DICACHE}{$fCode});
|
|
my $di = $hash->{DICACHE}{$fCode}; # cached device info
|
|
|
|
my $unpack = $di->{UNPACK}; # unpack for custom fcode?
|
|
my @fNames = @{$di->{FNAMES}}; # field names for unpack
|
|
my @extras = @{$di->{EXTRAS}}; # extra expressions
|
|
my @fields = ($unpack ne 'none') ? unpack ($unpack, $data) : (); # unpack data
|
|
|
|
$pduHash->{TYPE} = $di->{TYPE} if ($di->{TYPE});
|
|
my $logFld = '';
|
|
foreach my $fld (@fNames) { # assign fields and apply expr if applicable
|
|
my $val = shift @fields;
|
|
my $expr = $di->{EXPRS}{$fld};
|
|
my $new = $val;
|
|
if ($expr) {
|
|
$new = EvalExpr($hash, {expr => $expr, val => $val, action => "field expr for $fld", '$pduHash' => $pduHash});
|
|
Log3 $name, 5, "$name: parsePDU $fld after expr ($expr) is "
|
|
. HexIfNeeded($new) . " (before: " . (HexIfNeeded($val) // 'null') . ")";
|
|
} else {
|
|
Log3 $name, 5, "$name: parsePDU $fld is " . HexIfNeeded($new);
|
|
}
|
|
$pduHash->{$fld} = $new; # set PDU hash field
|
|
$logFld .= ($logFld ? ', ' : '') . "$fld = " . HexIfNeeded($new);
|
|
}
|
|
foreach my $fld (@extras) { # modify potential additional fields like PDULEXP after assigning all unpacked fields
|
|
my $expr = $di->{EXPRS}{$fld};
|
|
my $val = $pduHash->{$fld} // '';
|
|
my $new = EvalExpr($hash, {expr => $expr, val => $pduHash->{$fld}, '$pduHash' => $pduHash});
|
|
Log3 $name, 5, "$name: extra field $fld after expr ($expr) is " . HexIfNeeded($new);
|
|
$logFld .= ($logFld ? ', ' : '') . "$fld = " . HexIfNeeded($new);
|
|
$pduHash->{$fld} = $new; # set PDU hash
|
|
}
|
|
Log3 $name, 5, "$name: parsePDU function code $fCode: data: " . unpack ('H*', $data)
|
|
. " with unpack code $unpack" . (@fNames ? " to fields " . join (',', @fNames) : '')
|
|
. ' results in values: ' . $logFld;
|
|
if (!$frame->{PDULEXP}) { # if net set from the TCP frame
|
|
$frame->{PDULEXP} = ($pduHash->{PDULEXP} ? $pduHash->{PDULEXP} : 1);
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Parse Response, called from handleResponse
|
|
# require {FRAME} to be filled before by HandleFrameStart
|
|
# fill {RESPONSE} and some more fields of {FRAME}
|
|
# $frame->{PDULEXP} is set so the following functions can see if they still need to wait for more data
|
|
sub ParseResponse {
|
|
my $hash = shift; # the physical device hash
|
|
my $response = shift; # response structure to be filled, already contains adr/len/operation/masterhash/relayhash from request
|
|
my $mHash = shift; # the logical master device to access parsing attrs, can be undef!
|
|
my $name = $hash->{NAME};
|
|
my $mName = $mHash ? $mHash->{NAME} : '';
|
|
my $frame = $hash->{FRAME} // {};
|
|
my $request = $hash->{REQUEST};
|
|
my $fCode = $frame->{FCODE}; # filled in handleFrameStart
|
|
my $data = $frame->{DATA};
|
|
my $unpack;
|
|
|
|
if ($mHash) {
|
|
createDevInfoCache($mHash, $fCode, 'Response') if (!$mHash->{DICACHE}{$fCode});
|
|
my $di = $mHash->{DICACHE}{$fCode}; # cached device info
|
|
$unpack = $di->{UNPACK}; # unpack for custom fcode?
|
|
}
|
|
|
|
Log3 $name, 5, "$name: ParseResponse called from " . FhemCaller() . ", fc $fCode"
|
|
. ($unpack ? ", custom fc unpack $unpack" : '');
|
|
|
|
use bytes;
|
|
$response->{FCODE} = $fCode;
|
|
$response->{MODBUSID} = $frame->{MODBUSID};
|
|
if ($request) {
|
|
$response->{ADR} = $request->{ADR}; # prefill
|
|
$response->{LEN} = $request->{LEN};
|
|
$response->{TYPE} = $request->{TYPE};
|
|
$response->{OPERATION} = $request->{OPERATION}; # for later call to ParseDataString
|
|
}
|
|
|
|
# if we don't have enough data then checksum check will fail later which is fine.
|
|
# however unpack might produce undefined results if there is not enough data so return early.
|
|
my $dataLength = length($data);
|
|
if ($unpack) { # custom fCode defined or brokenFCx
|
|
parsePDU($mHash, $frame, $response, 'Response');
|
|
}
|
|
elsif ($fCode == 1 || $fCode == 2) {
|
|
# read coils / discrete inputs, pdu: fCode, num of bytes, coils
|
|
# adr and len are already copied from request
|
|
return if ($dataLength) < 1;
|
|
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->{TYPE} = ($fCode == 1 ? 'c' : 'd'); # coils or discrete inputs
|
|
$frame->{PDULEXP} = $len + 2; # 1 Byte fCode + 1 Byte len + len of expected values
|
|
}
|
|
elsif ($fCode == 3 || $fCode == 4) {
|
|
# read holding/input registers, pdu: fCode, num of bytes, registers
|
|
return if ($dataLength) < 1;
|
|
my ($len, $values) = unpack ('Ca*', $data);
|
|
$response->{TYPE} = ($fCode == 3 ? 'h' : 'i'); # holding registers / input registers
|
|
$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;
|
|
}
|
|
elsif ($fCode == 5) {
|
|
# write single coil, pdu: fCode, adr, coil (FF00)
|
|
return if ($dataLength) < 3;
|
|
my ($adr, $values) = unpack ('nH4', $data); # 2 bytes adr, 2 bytes values
|
|
$response->{ADR} = $adr; # adr of coil
|
|
$response->{LEN} = 1; # always one coil
|
|
$values = ($values eq 'ff00' ? 1 : 0);
|
|
$response->{VALUES} = pack ('c', $values); # bit as binary string
|
|
$response->{TYPE} = 'c'; # coils
|
|
$frame->{PDULEXP} = 5; # 1 Byte fCode + 2 Bytes adr + 2 Bytes coil
|
|
}
|
|
elsif ($fCode == 6) {
|
|
# write single (holding) register, pdu: fCode, adr, register
|
|
return if ($dataLength) < 2;
|
|
my ($adr, $values) = unpack ('na*', $data);
|
|
$response->{ADR} = $adr; # adr of register
|
|
$response->{VALUES} = $values;
|
|
$response->{TYPE} = 'h'; # holding registers
|
|
$frame->{PDULEXP} = 5; # 1 Byte fCode + 2 Bytes adr + 2 Bytes register
|
|
}
|
|
elsif ($fCode == 15 || $fCode == 16) {
|
|
# write mult coils/holding registers, pdu: fCode, adr, len
|
|
return if ($dataLength) < 2;
|
|
$response->{TYPE} = ($fCode == 15 ? 'c' : 'c'); # coils / holding registers
|
|
$frame->{PDULEXP} = 5; # 1 byte fCode + 2 byte adr + 2 bytes len
|
|
# response to fc 15 / 16 does not contain data -> nothing to be done, ParseDataString will not be called
|
|
}
|
|
elsif ($fCode >= 128) {
|
|
# error fCode pdu: fCode, data
|
|
return if ($dataLength) < 1;
|
|
$response->{ERRCODE} = unpack ('H2', $data);
|
|
$frame->{PDULEXP} = 2; # 1 byte error fCode + 1 code
|
|
}
|
|
else { # other function code / raw send?
|
|
if ($request && $request->{FCODE} && $request->{FCODE} == 999) {
|
|
$response->{VALUES} = $data;
|
|
if (!$frame->{PDULEXP}) { # if net set from the TCP frame
|
|
$frame->{PDULEXP} = 999; # maybe just fcode, maybe lots of data ...
|
|
}
|
|
}
|
|
else {
|
|
Log3 $name, 5, "$name: ParseResponse got unknown fcode $fCode";
|
|
AddFrameError($frame, "Function code $fCode not implemented");
|
|
if (!$frame->{PDULEXP}) { # if net set from the TCP frame
|
|
$frame->{PDULEXP} = 1; # unknown - assume at least 1 byte fc
|
|
}
|
|
}
|
|
}
|
|
$response->{PDU} = pack ('C', $fCode)
|
|
. ($data ? substr($data, 0, $frame->{PDULEXP}) : '');
|
|
|
|
CheckChecksum($hash); # calls AddFrameError if needed ($frame->{ERROR})
|
|
|
|
my $allowShort = DevInfo($mHash, $response->{TYPE}, 'allowShortResponses');
|
|
my $frLenExp = $frame->{PDULEXP} + $PDUOverhead{$hash->{PROTOCOL}}; # expected frame length
|
|
my $readLen = length($hash->{READ}{BUFFER}); # current frame length
|
|
return 1 if ($readLen >= $frLenExp); # frame seems complete, continue with next steps
|
|
Log3 $name, 5, "$name: ParseResponse got $readLen but expecting $frLenExp bytes"
|
|
if ($frame->{PDULEXP} != 999); # don't log if expected lenght is unknown (999)
|
|
return if ($frame->{ERROR}); # error so far - wait for more data or timeout
|
|
# frame is too small but no error - even checksum is fine!
|
|
return 1 if ($allowShort || $frame->{PDULEXP} == 999); # frame seems valid, continue with next steps
|
|
Log3 $name, 4, "$name: ParseResponse got short but valid frame. set allowShortResponses to allow";
|
|
return; # short not allowed -> continue / wait for more data
|
|
}
|
|
|
|
|
|
#####################################################
|
|
# create a reading name for objects while scanning
|
|
sub ScanReadingName {
|
|
my $logHash = shift;
|
|
my $reading = shift;
|
|
my $type = shift;
|
|
my $startAdr = shift;
|
|
my $op = shift;
|
|
my $name = $logHash->{NAME};
|
|
my $key = $type . $startAdr;
|
|
|
|
if ($op =~ /scanid([0-9]+)/) { # scanning for Modbus ID
|
|
$reading = 'scanId-' . $1 . "-Response-$key";
|
|
$logHash->{MODBUSID} = $1;
|
|
Log3 $name, 3, "$name: ScanReadingName scanIds got response from Id $1 - set internal MODBUSID to $1";
|
|
return $reading;
|
|
}
|
|
# scan Modbus objects
|
|
Log3 $name, 5, "$name: ScanReadingName scanobj reading=$reading";
|
|
if (!$reading) {
|
|
my $fKey = $type . sprintf ('%05d', $startAdr); # objcombi with leading zeros
|
|
$reading = "scan-$fKey";
|
|
Log3 $name, 5, "$name: ScanReadingName scanobj sets reading=$reading";
|
|
CommandAttr(undef, "$name obj-${fKey}-reading $reading");
|
|
}
|
|
return $reading;
|
|
}
|
|
|
|
|
|
#################################################
|
|
# called from CreateDataObjects to format
|
|
# responses with different types while scanning
|
|
sub ScanFormat {
|
|
my $hash = shift;
|
|
my $val = shift;
|
|
my $name = $hash->{NAME};
|
|
use bytes;
|
|
my $len = length($val);
|
|
my $i = unpack('s', $val);
|
|
my $n = unpack('S', $val);
|
|
my $h = unpack('H*', $val);
|
|
Log3 $name, 5, "$name: ScanFormat hex=$h, bytes=$len";
|
|
|
|
my $ret = "hex=$h, string=";
|
|
for my $c (split //, $val) {
|
|
$ret .= $c =~ /[[:graph:]]/ ? $c : '.';
|
|
}
|
|
|
|
$ret .= ', s=' . unpack('s', $val) .
|
|
', s>=' . unpack('s>', $val) .
|
|
', S=' . unpack('S', $val) .
|
|
', S>=' . unpack('S>', $val);
|
|
if ($len > 2) {
|
|
$ret .= ', i=' . unpack('s', $val) .
|
|
', i>=' . unpack('s>', $val) .
|
|
', I=' . unpack('S', $val) .
|
|
', I>=' . unpack('S>', $val);
|
|
|
|
$ret .= ', f=' . unpack('f', $val) .
|
|
', f>=' . unpack('f>', $val);
|
|
|
|
#my $r1 = substr($h, 0, 4);
|
|
#my $r2 = substr($h, 4, 4);
|
|
#my $rev = pack ('H*', $r2 . $r1);
|
|
#$ret .= ', revf=' . unpack('f', $rev) .
|
|
#', revf>=' . unpack('f>', $rev);
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
|
|
#####################################################################
|
|
# decode and then encode all array elements
|
|
# called from CreateDataObjects
|
|
sub arrayEncoding {
|
|
my $hash = shift;
|
|
my $aRef = shift;
|
|
my $decode = shift;
|
|
my $encode = shift;
|
|
my $name = $hash->{NAME};
|
|
return if (!$decode && !$encode);
|
|
|
|
for (my $i=0; $i < @{$aRef}; $i++) {
|
|
$aRef->[$i] = decode($decode, $aRef->[$i]) if ($decode);
|
|
$aRef->[$i] = encode($encode, $aRef->[$i]) if ($encode);
|
|
}
|
|
Log3 $name, 5, "$name: arrayEncoding for " . FhemCaller() . " modified charset of $aRef to: " . ReadableArray($aRef);
|
|
return;
|
|
}
|
|
|
|
|
|
##################################################
|
|
# slave got data to write from its master
|
|
sub WriteObject {
|
|
my $hash = shift;
|
|
my $transPtr = shift;
|
|
my $type = shift;
|
|
my $adr = shift;
|
|
my $val = shift;
|
|
my $name = $hash->{NAME};
|
|
my $objCombi = $type . $adr;
|
|
my $reading = ObjInfo($hash, $objCombi, 'reading'); # '' if nothing specified
|
|
Log3 $name, 5, "$name: WriteObject called for $objCombi form " . FhemCaller();
|
|
if (!$reading) { # no parse information -> skip to next object
|
|
Log3 $name, 5, "$name: WriteObject has no information about handling $objCombi";
|
|
$transPtr->{ERRCODE} = DevInfo($hash, $type, 'addressErrCode', 2);
|
|
return;
|
|
}
|
|
if (!ObjInfo($hash, $objCombi, 'allowWrite', 'defAllowWrite', 0)) { # write allowed.
|
|
Log3 $name, 4, "$name: WriteObject refuses to set reading $reading (allowWrite not set)";
|
|
$transPtr->{ERRCODE} = DevInfo($hash, $type, 'notAllowedErrCode', 1);
|
|
return;
|
|
}
|
|
|
|
my $device = $name; # default device is myself
|
|
my $rname = $reading; # given name as reading name
|
|
my $dev = $hash;
|
|
if ($rname =~ /^([^\:]+):(.+)$/) { # can we split given name to device:reading?
|
|
$device = $1;
|
|
$rname = $2;
|
|
$dev = $defs{$device};
|
|
}
|
|
|
|
if (!CheckRange($hash, {val => $val, min => ObjInfo($hash, $objCombi, 'min'), max => ObjInfo($hash, $objCombi, 'max')} ) ) {
|
|
Log3 $name, 4, "$name: WriteObject ignores value $val because it is out of bounds for reading $rname of device $device";
|
|
$transPtr->{ERRCODE} = DevInfo($hash, $type, 'valueErrCode', 1); # for slave write processing
|
|
next OBJLOOP;
|
|
}
|
|
if (!TryCall($hash, 'ModbusReadingsFn', $reading, $val)) {
|
|
Log3 $name, 4, "$name: WriteObject assigns value $val to reading $rname of device $device";
|
|
if ($dev eq $hash) {
|
|
readingsBulkUpdate($dev, $rname, $val); # assign value to one of this devices readings
|
|
} else {
|
|
readingsSingleUpdate($dev, $rname, $val, 1); # assign value to reading - another Fhem device
|
|
}
|
|
}
|
|
$hash->{gotReadings}{$reading} = $val;
|
|
return;
|
|
}
|
|
|
|
|
|
#####################################################
|
|
# split data part in a response or write request
|
|
# into objects that later can be assigned to readings
|
|
# only called from ParseDataString
|
|
sub SplitDataString {
|
|
my $hash = shift;
|
|
my $transPtr = shift; # $transPtr can be response (mode master) or request (mode slave and write request)
|
|
my $name = $hash->{NAME};
|
|
my $type = $transPtr->{TYPE};
|
|
my $startAdr = $transPtr->{ADR};
|
|
my $valuesLen = $transPtr->{LEN}; # valuesLen is only used for coils / discrete inputs
|
|
my $op = $transPtr->{OPERATION} // '';
|
|
my $dataStr = $transPtr->{VALUES};
|
|
my $lastAdr = ($valuesLen ? $startAdr + $valuesLen -1 : 0);
|
|
my @objList; # result array of object hashes
|
|
|
|
Log3 $name, 5, "$name: SplitDataString called from " . FhemCaller() . " with data hex " . unpack ('H*', $transPtr->{VALUES}) .
|
|
", type $type, adr $startAdr" . ($valuesLen ? ", valuesLen $valuesLen" : '') . ($op ? ", op $op" : '');
|
|
|
|
if ($type =~ '[cd]') {
|
|
$valuesLen = 1 if (!$valuesLen);
|
|
$dataStr = unpack ("b$valuesLen", $transPtr->{VALUES}); # convert binary data to bit string
|
|
# for fc5 responses paresResponse already converts ff00 to 1. For requests the above unpack will also work for 0000 / ff00
|
|
Log3 $name, 5, "$name: SplitDataString shortened coil / input bit string to " . $dataStr . ", start adr $startAdr, valuesLen $valuesLen";
|
|
}
|
|
|
|
use bytes;
|
|
my ($reading, $unpack, $objLen, $byteLen, $expr);
|
|
OBJLOOP:
|
|
while (length($dataStr) > 0) { # parse every field / object passed in $transPtr structure
|
|
my $objCombi = $type . $startAdr;
|
|
$reading = ObjInfo($hash, $objCombi, 'reading'); # '' if nothing specified
|
|
if ($type =~ '[cd]') { # coils or digital inputs
|
|
$unpack = 'a'; # for coils just take the next byte with 0/1 from the string.
|
|
$objLen = 1; # to be used in continue block (go to next coil/input in unpacked bit string)
|
|
$byteLen = 1; # just take one byte from $dataStr
|
|
}
|
|
else { # holding / input register
|
|
if ($op =~ /^scan/) { # special handling / presentation if scanning
|
|
$objLen = length($dataStr) / 2; # length of rest as number of registers when scanning
|
|
$objLen = 1 if ($objLen < 1); # just to be sure
|
|
$unpack = 'a' . $objLen*2; # for Modbus::ScanFormat
|
|
$reading = ScanReadingName ($hash, $reading, $type, $startAdr, $op);
|
|
}
|
|
else { # not scanning - use unpack, len and expr from attributes
|
|
$objLen = ObjInfo($hash, $objCombi, 'len'); # default to 1 (1 Reg / 2 Bytes) with global attrDefaults
|
|
$unpack = ObjInfo($hash, $objCombi, 'unpack');
|
|
}
|
|
$byteLen = $objLen * 2; # one register is two bytes from $dataStr
|
|
}
|
|
if (!$reading) { # no parse information -> skip to next object
|
|
Log3 $name, 5, "$name: SplitDataString has no information about handling $objCombi";
|
|
$transPtr->{ERRCODE} = DevInfo($hash, $type, 'addressErrCode', 2) if ($hash->{MODE} eq 'slave');
|
|
next OBJLOOP;
|
|
}
|
|
my %obj;
|
|
$obj{objCombi} = $objCombi;
|
|
$obj{reading} = $reading;
|
|
$obj{unpack} = $unpack;
|
|
$obj{adr} = $startAdr;
|
|
$obj{len} = $objLen;
|
|
$obj{data} = substr($dataStr, 0, $byteLen);
|
|
$obj{group} = ObjInfo($hash, $objCombi, 'group');
|
|
push @objList, \%obj;
|
|
}
|
|
continue { # take next object in data string
|
|
if ($type =~ '[cd]') {
|
|
$startAdr++;
|
|
$dataStr = (length($dataStr) > 1 ? substr($dataStr, 1) : '');
|
|
last OBJLOOP if ($lastAdr && $startAdr > $lastAdr); # only set for unpacked coil / input bit string
|
|
}
|
|
else {
|
|
$startAdr += $objLen;
|
|
$dataStr = (length($dataStr) > ($byteLen) ? substr($dataStr, $byteLen) : '');
|
|
}
|
|
#Log3 $name, 5, "$name: SplitDataString moves to next object, skip $objLen to $type$startAdr" if ($dataStr);
|
|
}
|
|
return \@objList;
|
|
}
|
|
|
|
|
|
sub CreateParseInfoCache {
|
|
my $hash = shift;
|
|
my $objCombi = shift;
|
|
my $name = $hash->{NAME};
|
|
Log3 $name, 5, "$name: CreateParseInfoCache called";
|
|
$hash->{PICACHE}{$objCombi} =
|
|
{ 'revRegs' => ObjInfo($hash, $objCombi, 'revRegs'),
|
|
'bswapRegs' => ObjInfo($hash, $objCombi, 'bswapRegs'),
|
|
'decode' => ObjInfo($hash, $objCombi, 'decode'),
|
|
'encode' => ObjInfo($hash, $objCombi, 'encode'),
|
|
'ignoreExpr' => ObjInfo($hash, $objCombi, 'ignoreExpr'),
|
|
'expr' => ObjInfo($hash, $objCombi, 'expr'),
|
|
'map' => ObjInfo($hash, $objCombi, 'map'),
|
|
'mapDefault' => ObjInfo($hash, $objCombi, 'mapDefault'),
|
|
'rmapDefault' => ObjInfo($hash, $objCombi, 'rmapDefault'),
|
|
'format' => ObjInfo($hash, $objCombi, 'format'),
|
|
};
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
#######################################################
|
|
# create readings from a hash containing all data parts
|
|
# with unpack, map, format and so on
|
|
# called from ParseDataString which is called from HandleResponse
|
|
sub CreateDataObjects {
|
|
my $hash = shift;
|
|
my $objList = shift;
|
|
my $transPtr = shift; # $transPtr can be response (mode master) or request (mode slave and write request)
|
|
my $name = $hash->{NAME};
|
|
|
|
Log3 $name, 5, "$name: CreateDataObjects called from " . FhemCaller() . " with objList "
|
|
. join ',', map {$_->{objCombi}} @{$objList};
|
|
my @sortedList = sort compObjGroups @{$objList}; # sorted by group and pos in group, then type / adr
|
|
Log3 $name, 5, "$name: CreateDataObjects sortedList "
|
|
. join ',', map {$_->{objCombi}} @sortedList;
|
|
|
|
readingsBeginUpdate($hash);
|
|
OBJLOOP:
|
|
foreach my $obj (@sortedList) {
|
|
my $objCombi = $obj->{objCombi};
|
|
my $objData = $obj->{data};
|
|
|
|
if ($hash->{PICACHE}{$objCombi}) {
|
|
#Log3 $name, 5, "$name: Cached parse info exists for $objCombi";
|
|
CreateParseInfoCache($hash, $objCombi) if (!AttrVal($name, 'cacheParseInfo', 0));
|
|
} else {
|
|
CreateParseInfoCache($hash, $objCombi); # no entry -> recreate for this objCombi
|
|
}
|
|
my $pi = $hash->{PICACHE}{$objCombi}; # cached for this objCombi until attrs change
|
|
|
|
$objData = ReverseWordOrder($hash, $objData, $obj->{len}) if ($pi->{'revRegs'});
|
|
$objData = SwapByteOrder ($hash, $objData, $obj->{len}) if ($pi->{'bswapRegs'});
|
|
|
|
my @val = unpack ($obj->{unpack}, $objData); # fill @val array in case unpack contains codes for more fields, other elements can be used in expr later.
|
|
if (!defined($val[0])) { # undefined value as result of unpack -> skip to next object
|
|
my $logLvl = AttrVal($name, 'timeoutLogLevel', 3);
|
|
Log3 $name, $logLvl, "$name: CreateDataObjects unpack of " . unpack ('H*', $objData) . " with $obj->{unpack} for $obj->{reading} resulted in undefined value";
|
|
next OBJLOOP;
|
|
}
|
|
Log3 $name, 5, "$name: CreateDataObjects unpacked " . unpack ('H*', $objData) . " with $obj->{unpack} to " . ReadableArray(\@val);
|
|
arrayEncoding($hash, \@val, $pi->{'decode'}, $pi->{'encode'}) if ($pi->{'decode'} || $pi->{'encode'});
|
|
my $val = $val[0];
|
|
|
|
next OBJLOOP if ($pi->{'ignoreExpr'} && EvalExpr($hash, # ignore exp results true -> skip to next object
|
|
{expr => $pi->{'ignoreExpr'}, val => $val, '@val' => \@val,
|
|
nullIfNoExp => 1, action => "ignoreExpr for $obj->{reading}"}));
|
|
|
|
if ($transPtr->{OPERATION} && $transPtr->{OPERATION} =~ /^scan/) {
|
|
$val = ScanFormat($hash, $val); # interpretations with diferent unpack codes
|
|
}
|
|
else {
|
|
$val = EvalExpr($hash, {val => $val, expr => $pi->{'expr'}, '%val' => \@val}) if ($pi->{'expr'});
|
|
$val = MapConvert($hash, {val => $val, map => $pi->{'map'},
|
|
default => $pi->{'mapDefault'},
|
|
undefIfNoMatch => 0}) if ($pi->{'map'});
|
|
$val = FormatVal($hash, {val => $val, format => $pi->{'format'}}) if ($pi->{'format'});
|
|
}
|
|
|
|
if ($hash->{MODE} eq 'slave') {
|
|
WriteObject($hash, $transPtr, $transPtr->{TYPE}, $obj->{adr}, $val); # do slave write
|
|
}
|
|
else {
|
|
if (!TryCall($hash, 'ModbusReadingsFn', $obj->{reading}, $val)) { # unless a user module defined ModbusReadingsFn
|
|
Log3 $name, 4, "$name: CreateDataObjects assigns value $val to $obj->{reading}";
|
|
readingsBulkUpdate($hash, $obj->{reading}, $val);
|
|
}
|
|
$hash->{gotReadings}{$obj->{reading}} = $val;
|
|
$hash->{lastRead}{$objCombi} = gettimeofday(); # used for pollDelay checking by getUpdate (mode master)
|
|
}
|
|
}
|
|
readingsEndUpdate($hash, 1);
|
|
return;
|
|
}
|
|
|
|
|
|
################################################################################
|
|
# Parse holding / input register / coil Data
|
|
# called from HandleResponse or from HandleRequest (for write requests as slave)
|
|
# with logical device hash, data string and the object type/adr to start with
|
|
sub ParseDataString {
|
|
my $hash = shift;
|
|
my $transPtr = shift; # $transPtr can be response (mode master) or request (mode slave and write request)
|
|
my $name = $hash->{NAME};
|
|
|
|
Log3 $name, 5, "$name: ParseDataString called from " . FhemCaller() . " with data hex " . unpack ('H*', $transPtr->{VALUES}) .
|
|
", type $transPtr->{TYPE}, adr $transPtr->{ADR}" . ($transPtr->{OPERATION} ? ", op $transPtr->{OPERATION}" : '');
|
|
delete $hash->{gotReadings}; # will be filled later and queried by caller. Used for logging and return value in get-command
|
|
|
|
my $obj = SplitDataString($hash, $transPtr); # split value string into objects in a new hash with its parameters from attrs
|
|
if ($transPtr->{ERRCODE}) {
|
|
Log3 $name, 5, "$name: ParseDataString returns because ERRCODE was set while splitting objects";
|
|
return;
|
|
}
|
|
|
|
CreateDataObjects($hash, $obj, $transPtr);
|
|
|
|
Log3 $name, 5, "$name: ParseDataString created " . scalar keys (%{$hash->{gotReadings}}) . " readings, errcode " . ($transPtr->{ERRCODE} // 'undef');
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################################################
|
|
# called from read when we are passive, a slave or relay (receiving part)
|
|
# and we are reading a new request
|
|
#
|
|
# call parse request, get logical device responsible and write / read data as requested
|
|
# call CreateResponse to create and send a response
|
|
#
|
|
# when called we have $hash->{FRAME}{MODBUSID}, $hash->{FRAME}{FCODE}, $hash->{FRAME}{DATA}
|
|
# and for TCP also $hash->{FRAME}{PDULEXP} and $hash->{FRAME}{TID}
|
|
#
|
|
# return undef if read should continue reading or 1 if we can react on data that was read
|
|
#
|
|
# for relay: when a new request comes in and another on is still not answered,
|
|
# the old one can not be canceled so we block any further requests from beeing accepted
|
|
# before the forwarding side runs into timeout or has answered.
|
|
# RelayRequest takes care of this.
|
|
#
|
|
#
|
|
sub HandleRequest {
|
|
my $hash = shift; # physical or TCP connection device hash
|
|
my $name = $hash->{NAME}; # name of physical serial device or the tcp connection device
|
|
my $frame = $hash->{FRAME};
|
|
my $id = $frame->{MODBUSID};
|
|
my $fCode = $frame->{FCODE};
|
|
my $logHash = GetLogHash($hash, $id); # look for Modbus logical slave or relay device (right id)
|
|
my $msg = '';
|
|
delete $hash->{REQUEST}; # any old request in io dev is outdated now
|
|
|
|
Log3 $name, 5, "$name: HandleRequest called from " . FhemCaller();
|
|
|
|
my %requestData; # create new request structure
|
|
my $request = \%requestData;
|
|
|
|
if (!ParseRequest($hash, $logHash, $request)) { # take frame hash and fill request hash
|
|
if (!$frame->{ERROR}) {
|
|
Log3 $name, 5, "$name: HandleRequest could not parse request frame yet, wait for more data"
|
|
. ($frame->{ERROR} ? ' (' . $frame->{ERROR} .')' : '');
|
|
return # continue reading
|
|
}
|
|
}
|
|
# for unknown fCode $request->{ERRCODE} as well as $frame->{ERROR} are set by ParseRequest, later CreateResponse copies ERRCODE from Request into Response
|
|
# ParseRequest also calls CheckChecksum to set $hash->{FRAME}{CHECKSUMERROR} if necessary
|
|
|
|
# got a full frame - maybe we can't handle it (unsupported fCode -> ERRCODE, set by parseRequest)
|
|
Profiler($hash, 'Fhem');
|
|
|
|
$hash->{REQUEST} = $request; # stick request data to physical or tcp connection hash for parsing the response (e.g. passive), no effect on relays where relay device != master
|
|
# needed for replying back as relay, keeping track in mode passive
|
|
# for relays $hash is the relay slave side io device which receives a request
|
|
# this is forwarded via another io hash on the forwarding master side (not visible here)
|
|
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 {
|
|
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
|
|
if ($hash->{MODE} eq 'slave') {
|
|
if (!$request->{ERRCODE} && exists $fcMap{$fCode}{write}) { # supported write fCode request contains data to be parsed and stored
|
|
my $pLogHash = ($logHash->{CHILDOF} ? $logHash->{CHILDOF} : $logHash);
|
|
Log3 $name, 5, "$name: passing value string of write request to ParseDataString to set readings";
|
|
ParseDataString($pLogHash, $request); # parse the request value, set reading with formatting etc. like for replies
|
|
# ParseDataString can also set ERRCODE (illegal address, value out of bounds) so CreateResponse/PackResponse will create an error message back to master
|
|
}
|
|
CreateResponse($hash, $logHash, $request); # create and send response, data or unsupported fCode error if request->{ERRCODE} and {ERROR} were set during parse
|
|
$hash->{EXPECT} = 'request';
|
|
}
|
|
elsif ($hash->{MODE} eq 'relay') {
|
|
$request->{RELAYHASH} = $logHash; # remember who to pass the response to
|
|
weaken $request->{RELAYHASH};
|
|
RelayRequest($hash, $request, $frame); # even if unspported fCode ...
|
|
$hash->{EXPECT} = 'request'; # just to be safe, should already be request
|
|
}
|
|
elsif ($hash->{MODE} eq 'passive') {
|
|
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
|
|
}
|
|
} else { # none of our ids
|
|
$hash->{EXPECT} = 'response'; # not our request, parse response that follows
|
|
$msg .= ', frame is not for us';
|
|
}
|
|
}
|
|
my $text = 'HandleRequest Done' . $msg . ($hash->{FRAME}{ERROR} ? ", error: $hash->{FRAME}{ERROR}" : '');
|
|
LogFrame($hash, $text, 4);
|
|
Profiler($hash, 'Idle');
|
|
delete $hash->{RESPONSE}; # remove response structure from physical io hash
|
|
return 1; # error or not, parsing is done.
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Parse Request, only called from handleRequest
|
|
# require $physHash->{FRAME} to be filled before by HandleFrameStart
|
|
# fills request hash,
|
|
# returns undef if not enough data, 1 if success or error ($request->{ERRCODE} is set)
|
|
# fills {PDULEXP} so the following functions can see if they still need to wait for more data
|
|
sub ParseRequest {
|
|
my $hash = shift;
|
|
my $lHash = shift;
|
|
my $request = shift;
|
|
my $name = $hash->{NAME};
|
|
my $frame = $hash->{FRAME} // {};
|
|
my $fCode = $frame->{FCODE}; # filled in handleFrameStart
|
|
my $data = $frame->{DATA};
|
|
my $cFc = 'fc' . $fCode . 'Request'; # key for potential custom function code
|
|
my $cFcUnpack = DevInfo($lHash, $cFc, 'unpack'); # unpack for custom fcode?
|
|
|
|
my $sHash;
|
|
$sHash = $lHash->{CHILDOF} if ($lHash->{CHILDOF}); # take info from parent device if TCP server conn
|
|
my $lName = $sHash->{NAME}; # for looking up attrs
|
|
|
|
Log3 $name, 5, "$name: ParseRequest called from " . FhemCaller();
|
|
|
|
use bytes;
|
|
my $dataLength = length($data);
|
|
$request->{FCODE} = $frame->{FCODE};
|
|
$request->{MODBUSID} = $frame->{MODBUSID};
|
|
$request->{TID} = $frame->{TID} if ($frame->{TID});
|
|
|
|
if ($cFcUnpack) { # custom fCode defined
|
|
parsePDU($lHash, $frame, $request, 'Request');
|
|
}
|
|
elsif ($fCode == 1 || $fCode == 2) {
|
|
# read coils / discrete inputs, pdu: fCode, StartAdr, Len (=number of coils)
|
|
return if ($dataLength) < 4; # minimum pdu length minus fcode
|
|
my ($adr, $len) = unpack ('nn', $data);
|
|
$request->{TYPE} = ($fCode == 1 ? 'c' : 'd'); # coils or discrete inputs
|
|
$request->{ADR} = $adr; # 16 Bit Coil / Input adr
|
|
$request->{LEN} = $len; # 16 Bit number of Coils / Inputs
|
|
$frame->{PDULEXP} = 5; # fCode + 2x16Bit
|
|
}
|
|
elsif ($fCode == 3 || $fCode == 4) {
|
|
# read holding/input registers, pdu: fCode, StartAdr, Len (=number of regs)
|
|
return if ($dataLength) < 4; # minimum pdu length minus fcode
|
|
my ($adr, $len) = unpack ('nn', $data);
|
|
$request->{TYPE} = ($fCode == 3 ? 'h' : 'i'); # holding registers / input registers
|
|
$request->{ADR} = $adr; # 16 Bit Coil / Input adr
|
|
$request->{LEN} = $len; # 16 Bit number of registers
|
|
$frame->{PDULEXP} = 5; # fCode + 2x16Bit
|
|
}
|
|
elsif ($fCode == 5) {
|
|
# write single coil, pdu: fCode, StartAdr, Value (1-bit as FF00)
|
|
return if ($dataLength) < 4; # minimum pdu length minus fcode
|
|
my ($adr, $value) = unpack ('na*', $data);
|
|
$request->{TYPE} = 'c'; # coil
|
|
$request->{ADR} = $adr; # 16 Bit Coil adr
|
|
$request->{LEN} = 1;
|
|
$request->{VALUES} = $value;
|
|
$frame->{PDULEXP} = 5; # fCode + 2 16Bit Values
|
|
}
|
|
elsif ($fCode == 6) {
|
|
# write single holding register, pdu: fCode, StartAdr, Value
|
|
return if ($dataLength) < 4; # minimum pdu length minus fcode
|
|
my ($adr, $value) = unpack ('na*', $data);
|
|
$request->{TYPE} = 'h'; # holding register
|
|
$request->{ADR} = $adr; # 16 Bit holding register adr
|
|
$request->{LEN} = 1;
|
|
$request->{VALUES} = $value;
|
|
$frame->{PDULEXP} = 5; # fCode + 2x16Bit
|
|
}
|
|
elsif ($fCode == 15) {
|
|
# write multiple coils, pdu: fCode, StartAdr, NumOfCoils, ByteCount, Values / bit
|
|
return if ($dataLength) < 6; # minimum pdu length minus fcode
|
|
my ($adr, $len, $bytes, $values) = unpack ('nnCa*', $data);
|
|
$request->{TYPE} = 'c'; # coils
|
|
$request->{ADR} = $adr; # 16 Bit Coil adr
|
|
$request->{LEN} = $len;
|
|
$request->{VALUES} = $values;
|
|
$frame->{PDULEXP} = 6 + $bytes; # fCode + 2x16Bit + bytecount + values
|
|
}
|
|
elsif ($fCode == 16) {
|
|
# write multiple regs, pdu: fCode, StartAdr, NumOfRegs, ByteCount, Values
|
|
my ($adr, $len, $bytes, $values) = unpack ('nnCa*', $data);
|
|
return if ($dataLength) < 6; # minimum pdu length minus fcode
|
|
$request->{TYPE} = 'h'; # coils
|
|
$request->{ADR} = $adr; # 16 Bit Coil adr
|
|
$request->{LEN} = $len;
|
|
$request->{VALUES} = $values;
|
|
$frame->{PDULEXP} = 6 + $bytes; # fCode + 2x16Bit + bytecount + values
|
|
}
|
|
elsif ($fCode == 17) {
|
|
# report server id (serial only) pdu: only fCode
|
|
$request->{ADR} = 0; # special request, no normal objects requested
|
|
$request->{LEN} = 0;
|
|
$frame->{PDULEXP} = 1; # nothing after fCode
|
|
}
|
|
else { # function code not implemented yet
|
|
$request->{ERRCODE} = 1; # error code 1 in Modbus response = illegal function
|
|
AddFrameError($frame, "Function code $fCode not implemented");
|
|
$frame->{PDULEXP} = 2;
|
|
}
|
|
$request->{PDU} = pack ('C', $fCode) . substr($data, 0, $frame->{PDULEXP});
|
|
CheckChecksum($hash); # set $hash->{FRAME}{CHECKSUMERROR} if wrong
|
|
|
|
my $frLenExp = $frame->{PDULEXP} + $PDUOverhead{$hash->{PROTOCOL}};
|
|
my $readLen = length($hash->{READ}{BUFFER});
|
|
return if ($readLen < $frLenExp ); # continue reading
|
|
return 1; # reading done, continue handling / dropping this frame
|
|
}
|
|
|
|
|
|
|
|
#######################################################
|
|
# get the valid io device for the relay forward device
|
|
# called with the logical device hash of a relay
|
|
# this relay device hash has hash->{RELAY} set to the name of the forward device
|
|
# also sets $hash->{RELID} (in the logical relay device)
|
|
# to the Modbus id of the relay forward device
|
|
sub GetRelayIO {
|
|
my $relayHash = shift;
|
|
$relayHash = $relayHash->{CHILDOF} if ($relayHash->{CHILDOF}); # switch to parent context if available
|
|
my $name = $relayHash->{NAME};
|
|
my $masterName;
|
|
my $masterHash;
|
|
my $masterIOHash;
|
|
my $msg;
|
|
|
|
if (!$relayHash->{RELAY}) {
|
|
$msg = 'GetRelay does not have a relay forward device';
|
|
}
|
|
else {
|
|
$masterName = $relayHash->{RELAY}; # name of the relay forward device as defined
|
|
$masterHash = $defs{$masterName};
|
|
#Log3 $name, 5, "$name: GetRelayIO for relay forward device $masterHash->{NAME}";
|
|
if (!$masterHash || !$masterHash->{MODULEVERSION} ||
|
|
$masterHash->{MODULEVERSION} !~ /^Modbus / || $masterHash->{MODE} ne 'master'
|
|
|| $masterHash->{TYPE} eq 'Modbus') {
|
|
$msg = "relay forward device $masterName is not a modbus master";
|
|
}
|
|
else {
|
|
# now we have a $masterHash for the logical relay forward device at least
|
|
$masterIOHash = GetIOHash($masterHash); # get io device hash of the relay forward device
|
|
my $slIOHash = GetIOHash($relayHash); # get io device hash of the relay slave part (has to be different). Check later if available
|
|
if (!$masterIOHash) {
|
|
$msg = 'no relay forward io device';
|
|
} elsif ($masterIOHash eq $slIOHash) {
|
|
$msg = 'relay forward io device must not must not be same as receiving device';
|
|
} else {
|
|
# now check for disabled devices
|
|
$msg = CheckDisable($masterHash); # is relay forward device or its io device disabled?
|
|
}
|
|
}
|
|
}
|
|
# don't check if relay io device is actually opened. This will be done when the queue is processed
|
|
if ($msg) {
|
|
Log3 $name, 3, "$name: GetRelayIO: $msg";
|
|
delete $relayHash->{RELID};
|
|
return;
|
|
}
|
|
$relayHash->{MASTERHASH} = $masterHash;
|
|
weaken $relayHash->{MASTERHASH};
|
|
$relayHash->{RELID} = $masterHash->{MODBUSID};
|
|
Log3 $name, 5, "$name: GetRelayIO found $masterIOHash->{NAME} as Modbus relay forward io device for $masterHash->{NAME} with id $masterHash->{MODBUSID}";
|
|
#Log3 $name, 5, "$name: GetRelayIO set RELID of $relayHash to $relayHash->{RELID}";
|
|
return $masterIOHash;
|
|
}
|
|
|
|
|
|
##################################################################################
|
|
# relay request to the specified relay device
|
|
# called from HandleRequest with the physical device hash that received the request
|
|
# as io device for the relay device which is referenced as $request->{RELAYHASH}
|
|
# (same for tcp connection but different if relay reads from serial)
|
|
sub RelayRequest {
|
|
my $hash = shift;
|
|
my $request = shift;
|
|
my $frame = shift;
|
|
my $name = $hash->{NAME}; # the io device of the device defined with MODE relay (received the 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
|
|
|
|
Log3 $name, 4, "$name: RelayRequest called from " . FhemCaller();
|
|
|
|
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 $id = $relayParentHash->{RELID}; # Modbus ID of relay target - set by GetRelayIO
|
|
my $masterHash = $relayParentHash->{MASTERHASH}; # Device hash of master used by relay - set by GetRelayIO
|
|
#Log3 $name, 5, "$name: RelayRequest got RELID of $relayParentHash as $id";
|
|
|
|
if (!$reIOHash) {
|
|
AddFrameError($frame, 'relay forward device unavailable'); # message in frame hash for logging
|
|
$request->{ERRCODE} = 10; # gw path unavail; 11=gw target fail to resp.
|
|
CreateResponse($hash, $relayHash, $request); # create and send error response with request data and errcode
|
|
return;
|
|
}
|
|
my $queue = $reIOHash->{QUEUE}; # request queue on forwarding side
|
|
my $topRequest = $queue->[0];
|
|
if ($topRequest && $topRequest->{RELAYHASH} eq $relayHash) { # if there is another request for this relay waiting
|
|
shift(@{$queue}); # remove first element in queue - its outdated now
|
|
}
|
|
|
|
if ($reIOHash->{EXPECT} eq 'response') { # forward side is still busy waiting for another reply - refuse another request
|
|
AddFrameError($frame, 'relay forward path busy'); # message in frame hash for log
|
|
$request->{ERRCODE} = 6; # slave busy
|
|
CreateResponse($hash, $relayHash, $request); # create and send an error response
|
|
return;
|
|
}
|
|
|
|
my %fRequest = %{$request}; # create a copy to modify and forward
|
|
|
|
$fRequest{MASTERHASH} = $masterHash;
|
|
weaken $fRequest{MASTERHASH};
|
|
LogFrame($hash, "RelayRequest via $reIOHash->{NAME}, Proto $reIOHash->{PROTOCOL} with id $id", 4);
|
|
if ($reIOHash->{PROTOCOL} eq 'TCP') { # forward as Modbus TCP?
|
|
my $tid = int(rand(255));
|
|
$fRequest{TID} = $tid; # new transaction id for Modbus TCP forwarding
|
|
}
|
|
$fRequest{MODBUSID} = $id; # Modified target ID for the request to forward
|
|
$fRequest{DBGINFO} = 'relayed';
|
|
$fRequest{FORCE} = 1; # force: put at pos 0 of queue
|
|
QueueRequest($reIOHash, \%fRequest);
|
|
return;
|
|
}
|
|
|
|
|
|
|
|
######################################################################################
|
|
# relay response back to the device that sent the original request.
|
|
# called from HandleResponse with the io hash of the device that received the response
|
|
# and the request that was modified and forwarded
|
|
# and the response received.
|
|
|
|
# zurücksenden muss bei tcp über den connection child hash gehen
|
|
# ebenso steht der original request im connection hash
|
|
# andererseits steht die aktuelle config im parent hash der connection...
|
|
|
|
# entscheidend ist {RELAYHASH}
|
|
# wird im request schon gesetzt und von dort in die Reponse übernommen
|
|
|
|
sub RelayResponse {
|
|
my $hash = shift;
|
|
my $request = shift;
|
|
my $response = shift; # hash and name refer to the forward side
|
|
my $name = $hash->{NAME}; # physical device that received a response
|
|
|
|
my $relayHash = $response->{RELAYHASH}; # hash of logical relay device that got the first request
|
|
my $ioHash = GetIOHash($relayHash); # the ioHash that received the original request
|
|
if (!$ioHash || !$relayHash) {
|
|
Log3 $name, 4, "$name: RelayResponse failed because slave (=server) side io device disappeared";
|
|
return;
|
|
}
|
|
|
|
my $origRequest = $ioHash->{REQUEST}; # needed ($hash->{REQUEST} was modified / forwarded)
|
|
|
|
if (!$origRequest->{MODBUSID}) {
|
|
Log3 $name, 4, "$name: RelayResponse failed because original request is missing. " .
|
|
'relayHash name ' . $relayHash->{NAME} . ' relay io hash name ' . $ioHash->{NAME} .
|
|
' ioHash request hash ' . $origRequest . ' type ' . ($origRequest->{TYPE} // 'undef') . ' adr ' . ($origRequest->{ADR} // 'undef');
|
|
return;
|
|
}
|
|
# adjust Modbus ID for back communication
|
|
$response->{MODBUSID} = $origRequest->{MODBUSID};
|
|
$response->{TID} = ($origRequest->{TID} ? $origRequest->{TID} : 0);
|
|
|
|
LogFrame($hash, "RelayResponse via $relayHash->{NAME}, ioDev $relayHash->{IODev}{NAME}", 4, $request, $response);
|
|
|
|
my $responseFrame = PackFrame($ioHash, $relayHash->{MODBUSID}, $response->{PDU}, $response->{TID});
|
|
SendFrame($ioHash, $relayHash->{MODBUSID}, $responseFrame, $relayHash);
|
|
Profiler($hash, 'Idle');
|
|
return;
|
|
}
|
|
|
|
|
|
#############################################################################################
|
|
# create and send a response
|
|
# called from HandleRequest, RelayRequest
|
|
# and responseTimeout (when a relay wants to inform its master about the downstream timeout)
|
|
#
|
|
# the start adr and length of the request is taken to assemble a response frame out of
|
|
# one or several objects
|
|
#
|
|
sub CreateResponse {
|
|
my $hash = shift;
|
|
my $logHash = shift;
|
|
my $request = shift;
|
|
$logHash = $logHash->{CHILDOF} if ($logHash->{CHILDOF});
|
|
my $name = $logHash->{NAME}; # name of logical device
|
|
|
|
Log3 $name, 5, "$name: CreateResponse called from " . FhemCaller() .
|
|
($request->{ERRCODE} ? ", errcode $request->{ERRCODE}" : '');
|
|
|
|
my %responseData; # create a new response structure
|
|
my $response = \%responseData;
|
|
$hash->{RESPONSE} = $response;
|
|
|
|
$response->{ADR} = $request->{ADR} // 0; # get values for response from request
|
|
$response->{LEN} = $request->{LEN} // 0;
|
|
$response->{TYPE} = $request->{TYPE} // '';
|
|
$response->{MODBUSID} = $request->{MODBUSID};
|
|
$response->{FCODE} = $request->{FCODE};
|
|
$response->{TID} = $request->{TID} if ($request->{TID});
|
|
$response->{ERRCODE} = $request->{ERRCODE} // 0; # initial value to avoid warnings with pack later
|
|
my $cFc = 'fc' . $response->{FCODE} . 'Response'; # key for potential custom function code
|
|
my $cFcQ = 'fc' . $response->{FCODE} . 'Request'; # key for potential custom function code request
|
|
|
|
# pack one or more values into a values string
|
|
if (exists $fcMap{$response->{FCODE}}{objReturn} && !$response->{ERRCODE}) {
|
|
$response->{VALUES} = PackObj($logHash, $response)
|
|
}
|
|
|
|
elsif ($response->{FCODE} == 17) {
|
|
my $serverId = EvalExpr($logHash, {expr => AttrVal($name, 'serverIdExpr', 'fhem')});
|
|
$response->{VALUES} = $serverId;
|
|
Log3 $name, 4, "$name: server id requested, send $serverId";
|
|
}
|
|
elsif (DevInfo($logHash, $cFc, 'unpack')) { # custom fcode?
|
|
my $fL = DevInfo($logHash, $cFcQ, 'fieldList');
|
|
if ($fL && $fL =~ /ADR/) { # request contained ADR field?
|
|
$response->{VALUES} = PackObj($logHash, $response)
|
|
}
|
|
}
|
|
|
|
Log3 $name, 5, "$name: CreateResponse calls PackFrame to prepare response pdu";
|
|
$response->{FCODE} += 128 if ($response->{ERRCODE});
|
|
my $responsePDU = PackResponse($hash, $logHash, $response); # creates response or error PDU Data if {ERRCODE} is set
|
|
my $responseFrame = PackFrame($hash, $response->{MODBUSID}, $responsePDU, $response->{TID});
|
|
Log3 $name, 4, "$name: CreateResponse sends " . ResponseText($response) .
|
|
", device $name ($hash->{PROTOCOL}), pdu " .
|
|
unpack ('H*', $responsePDU) . ", V $Module_Version";
|
|
SendFrame($hash, $response->{MODBUSID}, $responseFrame, $logHash);
|
|
Profiler($hash, 'Idle');
|
|
return;
|
|
}
|
|
|
|
|
|
##############################################################
|
|
# get the correct function code
|
|
# called from DoRequest
|
|
sub GetFC {
|
|
my $hash = shift; # logical device hash
|
|
my $request = shift; # request structure containing TYPE, ADR, LEN, OPERATION
|
|
my $type = $request->{TYPE};
|
|
my $objCombi = $request->{TYPE} . $request->{ADR};
|
|
my $len = $request->{LEN};
|
|
my $op = $request->{OPERATION} // 'read';
|
|
my $name = $hash->{NAME}; # name of logical device
|
|
my $fcKey = ($op =~ /^scan/ ? 'read' : $op); # scan becomes read function code
|
|
my $defFC = 3; # default fc if nothing in fcMap (should neer happen)
|
|
|
|
SEARCH: # find default function code first
|
|
foreach my $fc (keys %fcMap) {
|
|
if ($fcMap{$fc}{type} && $fcMap{$fc}{type} eq $type && exists $fcMap{$fc}{$op} && exists $fcMap{$fc}{default}) {
|
|
$defFC = $fc;
|
|
last SEARCH;
|
|
}
|
|
}
|
|
$defFC = 16 if ($defFC == 6 && $len > 1); # 6 becomes 16 for more than one register
|
|
my $fCode = DevInfo($hash, $type, $fcKey, $defFC); # attribute or devInfo Hash to get fc for "read" or "write"
|
|
my $override = ObjInfo($hash, $objCombi, 'overrideFC'.$op); # attr to override fc for read / write
|
|
$fCode = $override if ($override);
|
|
|
|
# error checking and warning
|
|
if (!$fCode) {
|
|
Log3 $name, 3, "$name: GetFC called from " . FhemCaller() . " did not find fCode for $fcKey type $type";
|
|
}
|
|
elsif ($fCode == 6 && $len > 1) {
|
|
Log3 $name, 3, "$name: GetFC called from " . FhemCaller() . ' tries to use function code 6 to write more than one register. This will not work!';
|
|
}
|
|
elsif ($fCode !~ /^[0-9]+$/) {
|
|
Log3 $name, 3, "$name: GetFC called from " . FhemCaller() . ' get fCode $fCode which is not numeric. This will not work!';
|
|
}
|
|
else {
|
|
#Log3 $name, 5, "$name: GetFC called from " . FhemCaller() . " returns fCode $fCode for $fcKey $objCombi len $len";
|
|
}
|
|
return $fCode;
|
|
}
|
|
|
|
|
|
##############################################################
|
|
# called from logical device functions
|
|
# get, set, scan etc. with logical device hash.
|
|
# Create request and call QueueRequest
|
|
|
|
# todo: use group definitions here as well if objects need to be requested together
|
|
|
|
sub DoRequest {
|
|
my $hash = shift;
|
|
my $request = shift;
|
|
my $name = $hash->{NAME}; # name of logical device
|
|
my $ioHash = GetIOHash($hash); # send queue is at physical hash
|
|
my $qlen = ($ioHash->{QUEUE} ? scalar(@{$ioHash->{QUEUE}}) : 0);
|
|
my $objCombi = $request->{TYPE} . $request->{ADR};
|
|
|
|
#Log3 $name, 4, "$name: DoRequest called from " . FhemCaller() . ' ' . RequestText($request);
|
|
return if (CheckDisable($hash)); # returns if there is no io device
|
|
|
|
$request->{MODBUSID} = $request->{OPERATION} =~ /^scanid([0-9]+)/ ? $1 : $hash->{MODBUSID};
|
|
$request->{READING} = ObjInfo($hash, $objCombi, 'reading');
|
|
$request->{LEN} = ObjInfo($hash, $objCombi, 'len') if (not exists $request->{LEN});
|
|
$request->{MASTERHASH} = $hash; # logical device in charge
|
|
$request->{TID} = int(rand(255)) if ($hash->{PROTOCOL} eq 'TCP'); # transaction id for Modbus TCP
|
|
$request->{FCODE} = GetFC($hash, $request);
|
|
weaken $request->{MASTERHASH};
|
|
return if (!$request->{FCODE});
|
|
|
|
# check if defined unpack code matches a corresponding len and log warning if appropriate
|
|
my $unpack = ObjInfo($hash, $objCombi, 'unpack');
|
|
Log3 $name, 3, "$name: DoRequest with unpack $unpack but len < 2 - please set obj-${objCombi}-Len!"
|
|
if ($request->{LEN} < 2 && $unpack =~ /[lLIqQfFNVD]/);
|
|
|
|
delete $ioHash->{RETRY};
|
|
#$ioHash->{REQUEST} = $request; # It might overwrite the one sent -> dont link here
|
|
LogFrame($hash, 'DoRequest called from ' . FhemCaller() . ' created new request', 4, $request);
|
|
QueueRequest($ioHash, $request); # queue and process / set queue timer depending on force
|
|
return;
|
|
}
|
|
|
|
|
|
|
|
########################################################################
|
|
# called from DoRequest, RelayRequest and ResponseTimeout (for retrying)
|
|
# with physical device hash and request
|
|
sub QueueRequest {
|
|
my $hash = shift; # the physical device hash (io hash to send a request through)
|
|
my $request = shift;
|
|
my $force = $request->{FORCE};
|
|
my $front = $request->{FRONT} || $request->{FORCE};
|
|
my $name = $hash->{NAME}; # name of physical device with the queue
|
|
my $qlen = ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0);
|
|
my $mName = ($request->{MASTERHASH} ? $request->{MASTERHASH}{NAME} : 'unknown');
|
|
my $lqMax = AttrVal($mName, 'queueMax', 100);
|
|
my $qMax = AttrVal($name, 'queueMax', $lqMax);
|
|
|
|
Log3 $name, 5, "$name: QueueRequest called from " . FhemCaller() .
|
|
" with $request->{TYPE}$request->{ADR}, qlen $qlen" .
|
|
(defined ($request->{MASTERHASH}) && $request->{MASTERHASH}{NAME} ? " from master $request->{MASTERHASH}{NAME}" : '' ) .
|
|
(defined ($request->{RELAYHASH}) && $request->{RELAYHASH}{NAME} ? " for relay $request->{RELAYHASH}{NAME}" : '' ) .
|
|
" through io device $hash->{NAME}";
|
|
|
|
return if (CheckDisable($hash)); # also returns if there is no io device
|
|
|
|
# check for queue doubles if not forcing
|
|
my $checkDoubles = (AttrVal($name, 'dropQueueDoubles', 0) || $request->{RELAYHASH});
|
|
if ($qlen && $checkDoubles && !$front) {
|
|
Log3 $name, 5, "$name: QueueRequest is checking if request for $request->{TYPE}$request->{ADR} is already in queue (len $qlen)";
|
|
foreach my $elem (@{$hash->{QUEUE}}) {
|
|
#Log3 $name, 5, "$name: QueueRequest checks $elem->{TYPE}$elem->{ADR} reqLen $elem->{LEN} to id $elem->{MODBUSID}?";
|
|
if($elem->{ADR} == $request->{ADR} && $elem->{TYPE} eq $request->{TYPE}
|
|
&& $elem->{LEN} == $request->{LEN} && $elem->{MODBUSID} eq $request->{MODBUSID}) {
|
|
Log3 $name, 4, "$name: QueueRequest found request already in queue - dropping";
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
my $now = gettimeofday();
|
|
$request->{QUEUED} = $now;
|
|
if(!$qlen) {
|
|
#Log3 $name, 5, "$name: QueueRequest is creating new queue";
|
|
$hash->{QUEUE} = [ $request ];
|
|
}
|
|
else {
|
|
#Log3 $name, 5, "$name: QueueRequest initial queue length is $qlen";
|
|
if ($qlen > $qMax) {
|
|
Log3 $name, 3, "$name: QueueRequest queue too long ($qlen), dropping new request";
|
|
} else {
|
|
if ($front) {
|
|
unshift (@{$hash->{QUEUE}}, $request); # prepend at beginning
|
|
} else {
|
|
push(@{$hash->{QUEUE}}, $request); # add to end of queue
|
|
}
|
|
}
|
|
}
|
|
if ($force) {
|
|
ProcessRequestQueue('direct:'.$name); # call directly - even wait if force is set
|
|
return;
|
|
}
|
|
readingsSingleUpdate($hash, 'QueueLength', ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0), 1) if (AttrVal($name, 'enableQueueLengthReading', 0));
|
|
|
|
StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0}); # try to open if closed
|
|
# process asap, after delays are over
|
|
return;
|
|
}
|
|
|
|
|
|
######################################################
|
|
# remove internal timer for next queue processing
|
|
sub NextRequestFromQueue {
|
|
my $ioHash = shift;
|
|
my $name = $ioHash->{NAME};
|
|
my $queue = $ioHash->{QUEUE};
|
|
my $qTo = AttrVal($name, 'queueTimeout', 20);
|
|
my $now = gettimeofday();
|
|
my $QLR = AttrVal($name, 'enableQueueLengthReading', 0);
|
|
my $request;
|
|
CLEANLOOP:
|
|
{ # get first usable entry or return if none
|
|
if(!$queue || !scalar(@{$queue})) { # nothing in queue -> return
|
|
readingsSingleUpdate($ioHash, 'QueueLength', 0, 1) if ($QLR);
|
|
return;
|
|
}
|
|
$request = $queue->[0]; # get top element from Queue
|
|
next CLEANLOOP if (!$request || !$request->{FCODE}); # skip invalid entry (should not happen)
|
|
$request->{QUEUED} = $now if (!$request->{QUEUED});
|
|
last CLEANLOOP if ($now - $request->{QUEUED} <= $qTo); # element is not outdated -> exit loop
|
|
} continue {
|
|
shift(@{$queue}); # remove first element and iterate
|
|
}
|
|
return $request
|
|
}
|
|
|
|
|
|
####################################################
|
|
# neue Funktion zum Prüfen der Delays vor dem Senden
|
|
sub CheckDelays {
|
|
my $ioHash = shift;
|
|
my $masterHash = shift;
|
|
my $request = shift;
|
|
my $force = $request->{FORCE};
|
|
my $min = 0;
|
|
my $name = $ioHash->{NAME};
|
|
my $masterName = $masterHash->{NAME};
|
|
my $now = gettimeofday();
|
|
my $reqId = $request->{MODBUSID};
|
|
my ($maxRest, $maxRestKey);
|
|
|
|
my $delays = {
|
|
busDelayRead => {
|
|
name => 'last activity on bus',
|
|
last => $ioHash->{REMEMBER}{lrecv} // 0,
|
|
last2 => $ioHash->{REMEMBER}{lsend} // 0,
|
|
delay => AttrVal($name, 'busDelay', 0),
|
|
},
|
|
clientSwitchDelay => {
|
|
name => 'last read with different id',
|
|
if => ($ioHash->{REMEMBER}{lid} && $reqId != $ioHash->{REMEMBER}{lid}),
|
|
last => $ioHash->{REMEMBER}{lrecv},
|
|
delay => AttrVal($name, 'clientSwitchDelay', 0),
|
|
},
|
|
commDelay => {
|
|
name => 'last communication with same device',
|
|
last => $masterHash->{REMEMBER}{lrecv},
|
|
delay => DevInfo($masterHash, 'timing', 'commDelay', 0.1),
|
|
},
|
|
sendDelay => {
|
|
name => 'last send to same device',
|
|
last => $masterHash->{REMEMBER}{lsend},
|
|
delay => DevInfo($masterHash, 'timing', 'sendDelay', 0.1),
|
|
},
|
|
};
|
|
|
|
DELAYLOOP:
|
|
foreach my $dKey (keys %{$delays}) {
|
|
if (exists $delays->{$dKey}{if} && !$delays->{$dKey}{if}) {
|
|
Log3 $name, 5, "$name: checkDelays $dKey is not relevant";
|
|
next DELAYLOOP;
|
|
}
|
|
if (!$delays->{$dKey}{delay}) {
|
|
Log3 $name, 5, "$name: checkDelays $dKey is not required";
|
|
next DELAYLOOP;
|
|
}
|
|
my $last = ($delays->{$dKey}{last1} && $delays->{$dKey}{last1} < $delays->{$dKey}{last}) ?
|
|
$delays->{$dKey}{last1} : ($delays->{$dKey}{last} // 0);
|
|
my $tDiff = $now - $last;
|
|
my $tDiffStr = $last ? sprintf('%.3f', $tDiff) . ' secs ago' : 'never';
|
|
my $require = $delays->{$dKey}{delay};
|
|
my $rest = $require - $tDiff;
|
|
$rest = $require if ($rest > $require); # just to be sure nothing went wrong
|
|
Log3 $name, 5, "$name: checkDelays $dKey, $delays->{$dKey}{name} was $tDiffStr, required delay is $delays->{$dKey}{delay}";
|
|
if ($rest > ($maxRest // 0)) {
|
|
$maxRest = $rest;
|
|
$maxRestKey = $dKey;
|
|
}
|
|
}
|
|
return if (!$maxRestKey); # no remaining delay > 0 -> go on with sending
|
|
$maxRest = sprintf('%.3f', $maxRest);
|
|
Profiler($ioHash, 'Delay');
|
|
if ($force) {
|
|
Log3 $name, 4, "$name: checkDelays found $maxRestKey not over, sleep for $maxRest forced";
|
|
sleep $maxRest;
|
|
Log3 $name, 4, "$name: checkDelays sleep done, go on with sending";
|
|
return; # contine with sending, Profiler key will be set there
|
|
}
|
|
Log3 $name, 4, "$name: checkDelays found $maxRestKey not over, set timer to try again in $maxRest";
|
|
StartQueueTimer($ioHash, \&Modbus::ProcessRequestQueue, {delay => $maxRest, silent => 1}); # call processRequestQueue when remaining delay is over
|
|
return 1; # processRequestQueue will return and wait to be called again later, keep Profiler in 'Delay'
|
|
}
|
|
|
|
|
|
#######################################
|
|
# Aufruf aus InternalTimer mit "queue:$name"
|
|
# oder direkt mit "direkt:$name, wobei name das physical device ist
|
|
# greift über den Request der Queue auf das logische Device zu
|
|
# um Timings und Zeitstempel zu verarbeiten
|
|
# setzt selbst wieder einen Timer nach qDelay (default 1 Sek)
|
|
|
|
# to be able to open tcp connections on demand and close them after communication
|
|
# ProcessRequestQueue should call open if necessary and then return / set timer with queueDelay
|
|
# to try again in x seconds.
|
|
# then the queue entries should have their own timeout so they can get removed e.g. after 10 seconds
|
|
# otherwise the queue will overflow sometimes.
|
|
# the age of entries is checked in NextRequestFromQueue and the entry removed if it is too old.
|
|
sub ProcessRequestQueue {
|
|
my ($ckey,$name) = split(':', shift);
|
|
my $ioHash = $defs{$name};
|
|
my $queue = $ioHash->{QUEUE};
|
|
my $now = gettimeofday();
|
|
my $qDelay = AttrVal($name, 'queueDelay', 1);
|
|
my $request = NextRequestFromQueue($ioHash);
|
|
my $force = $request->{FORCE};
|
|
my $reqId = $request->{MODBUSID};
|
|
my $mHash = $request->{MASTERHASH}; # the logical device from which the request came (relay/master)
|
|
my $qlen = scalar(@{$queue});
|
|
|
|
StopQueueTimer($ioHash, {silent => 1}); # maybe we were called direct
|
|
Log3 $name, 5, "$name: ProcessRequestQueue called from " . FhemCaller() . " as $ckey:$name, qlen $qlen" . ($force ? ", force" : '') .
|
|
($request ? ", request: " . RequestText($request) : ', no usable requests in queue');
|
|
return if (!$request); # nothing to send
|
|
|
|
my $msg = CheckDisable($mHash);
|
|
if ($msg) { # logical/physical device disabled, logged by CheckDisable
|
|
$msg = 'dropping queue because logical or io device is unavailable or disabled';
|
|
delete $ioHash->{QUEUE}; # drop whole queue
|
|
}
|
|
elsif (!IsOpen($ioHash)) {
|
|
$msg = 'device is disconnected';
|
|
DoOpen($ioHash); # try to open asynchronously so we can proceed after qDelay
|
|
}
|
|
elsif (!$init_done) { # fhem not initialized, wait with IO
|
|
$msg = 'device is not available yet (init not done)';
|
|
}
|
|
elsif ($ioHash->{MODE} && $ioHash->{MODE} ne 'master') {
|
|
$msg = 'dropping queue because device is not in mode master';
|
|
delete $ioHash->{QUEUE}; # drop whole queue
|
|
}
|
|
elsif ($ioHash->{EXPECT} eq 'response') { # still busy waiting for response to last request
|
|
$msg = 'Fhem is still waiting for response, ' . FrameText($ioHash);
|
|
}
|
|
readingsSingleUpdate($ioHash, 'QueueLength', ($queue ? scalar(@{$queue}) : 0), 1) if (AttrVal($name, 'enableQueueLengthReading', 0));
|
|
if ($msg) {
|
|
Profiler($ioHash, 'Idle') if ($ioHash->{EXPECT} ne 'response');
|
|
#Log3 $name, 5, "$name: debug last open was " . sprintf('%3.3f', ($now - $ioHash->{LASTOPEN})) . ' secs ago at ' . FmtTimeMs($ioHash->{LASTOPEN});
|
|
Log3 $name, 5, "$name: ProcessRequestQueue will return, $msg, " .
|
|
"qlen $qlen, try again in $qDelay seconds";
|
|
StartQueueTimer($ioHash, \&Modbus::ProcessRequestQueue, {silent => 0}); # try again after qDelay, no shorter waiting time obvious
|
|
return;
|
|
}
|
|
|
|
return if (CheckDelays($ioHash, $mHash, $request)); # might set Profiler to delay
|
|
|
|
DropBuffer($ioHash);
|
|
RemoveInternalTimer ("timeout:$name"); # remove potential existing ResponseTimeout timer - will be set later
|
|
|
|
my $pdu = PackRequest($ioHash, $mHash, $request); # pack PDU with function code, adr, data from request structure
|
|
if ($pdu) {
|
|
my $frame = PackFrame($ioHash, $reqId, $pdu, $request->{TID}); # pack PDU as RTU, ASCII / TCP
|
|
LogFrame ($ioHash, "ProcessRequestQueue (V$Module_Version) qlen $qlen, sending "
|
|
. ShowBuffer($ioHash, $frame) . " via $ioHash->{DeviceName}", 4, $request);
|
|
|
|
$request->{SENT} = $now;
|
|
$request->{FRAME} = $frame; # frame as data string for echo detection
|
|
$ioHash->{REQUEST} = $request; # save for later handling incoming response
|
|
$ioHash->{EXPECT} = 'response'; # expect to read a response
|
|
|
|
Statistics($ioHash, 'Requests');
|
|
SendFrame($ioHash, $reqId, $frame, $mHash); # send the request, set Profiler key to 'Send'
|
|
Profiler($ioHash, 'Wait'); # wait for response to our request
|
|
|
|
my $timeout = DevInfo($mHash, 'timing', 'timeout', ($request->{RELAYHASH} ? 1.5 : 2));
|
|
my $toTime = $now+$timeout;
|
|
InternalTimer($toTime, \&Modbus::ResponseTimeout, "timeout:$name", 0);
|
|
$ioHash->{nextTimeout} = $toTime; # to be able to calculate remaining timeout time in ReadAnswer
|
|
} else {
|
|
Log3 $name, 3, "ProcessRequestQueue (V$Module_Version) qlen $qlen cant send empty pdu";
|
|
}
|
|
|
|
shift(@{$queue}); # remove first element from queue
|
|
readingsSingleUpdate($ioHash, 'QueueLength', ($queue ? scalar(@{$queue}) : 0), 1) if (AttrVal($name, 'enableQueueLengthReading', 0));
|
|
StartQueueTimer($ioHash, \&Modbus::ProcessRequestQueue); # schedule next call if there are more items in the queue
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################
|
|
# Pack holding / input register / coil Data for a response,
|
|
# only called from createResponse which is only called from HandleRequest (slave mode)
|
|
# with logical device hash and the response hash
|
|
#
|
|
# two lengths:
|
|
# one (valuesLen) from the response hash LEN (copied from the request length)
|
|
# and one (len) from the objInfo for the current object
|
|
sub PackObj {
|
|
my $logHash = shift;
|
|
my $response = shift;
|
|
my $name = $logHash->{NAME};
|
|
my $valuesLen = $response->{LEN}; # length of the values string requested (registers / bits)
|
|
my $type = $response->{TYPE}; # object to start with
|
|
my $startAdr = $response->{ADR};
|
|
my $lastAdr = ($valuesLen ? $startAdr + $valuesLen -1 : 0);
|
|
my $data = '';
|
|
my $counter = 0;
|
|
|
|
#Log3 $name, 5, "$name: PackObj called from " . FhemCaller();
|
|
Log3 $name, 5, "$name: PackObj called from " . FhemCaller() . " with $type $startAdr" .
|
|
($valuesLen ? " and valuesLen $valuesLen" : '');
|
|
$valuesLen = 1 if (!$valuesLen);
|
|
use bytes;
|
|
|
|
while ($counter < $valuesLen) {
|
|
# einzelne Felder verarbeiten
|
|
my $objCombi = $type . $startAdr;
|
|
#Log3 $name, 5, "$name: PackObj at $objCombi, counter $counter, valuesLen $valuesLen";
|
|
my $reading = ObjInfo($logHash, $objCombi, 'reading'); # is data coming from a reading
|
|
my $expr = ObjInfo($logHash, $objCombi, 'setexpr'); # or a setexpr (convert to register data)
|
|
my $unpack = ObjInfo($logHash, $objCombi, 'unpack'); # pack code to use, defaults to n
|
|
my $len = ObjInfo($logHash, $objCombi, 'len'); # default to 1 Reg / 2 Bytes
|
|
my $decode = ObjInfo($logHash, $objCombi, 'decode'); # character decoding
|
|
my $encode = ObjInfo($logHash, $objCombi, 'encode'); # character encoding
|
|
my $revRegs = ObjInfo($logHash, $objCombi, 'revRegs'); # do not reverse register order by default
|
|
my $swpRegs = ObjInfo($logHash, $objCombi, 'bswapRegs'); # dont reverse bytes in registers by default
|
|
#Log3 $name, 5, "$name: PackObj at $objCombi, counter $counter, valuesLen $valuesLen, reading $reading";
|
|
$len = 1 if ($type =~ /[cd]/);
|
|
|
|
if (!$reading && !$expr) {
|
|
Log3 $name, 5, "$name: PackObj doesn't have reading or expr information for $objCombi";
|
|
my $code = DevInfo($logHash, $type, 'addressErrCode', 2);
|
|
if ($code) {
|
|
$response->{ERRCODE} = $code; # if set, packResponse will not use values string
|
|
Log3 $name, 5, "$name: PackObj sets error code to $code";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
my $val = 0;
|
|
# value from defined reading
|
|
if ($reading) { # Reading as source of value
|
|
my $device = $name; # default device is myself
|
|
my $rname = $reading; # given name as reading name
|
|
if ($rname =~ /^([^\:]+):(.+)$/) { # can we split given name to device:reading?
|
|
$device = $1;
|
|
$rname = $2;
|
|
}
|
|
$val = ReadingsVal($device, $rname, '');
|
|
Log3 $name, 4, "$name: PackObj for $objCombi is using reading $rname of device $device with value $val";
|
|
}
|
|
|
|
$val = EvalExpr($logHash, {expr => $expr, val => $val, '$type' => $type, '$startAdr' => $startAdr} );
|
|
$val = FormatVal($logHash, {val => $val, format => ObjInfo($logHash, $objCombi, 'format')});
|
|
$val = MapConvert($logHash, {map => ObjInfo($logHash, $objCombi, 'map'), # convert with reverse map
|
|
default => ObjInfo($logHash, $objCombi, 'rmapDefault'),
|
|
val => $val, reverse => 1, undefIfNoMatch => 1}); # undef if no match and no default
|
|
$val = 0 if (!defined($val)); # avoid working with undef when reverse map did not match
|
|
$val = decode($decode, $val) if ($decode); # decode
|
|
$val = encode($encode, $val) if ($encode); # encode again
|
|
|
|
if ($type =~ /[cd]/) {
|
|
$data .= ($val ? '1' : '0');
|
|
$counter++;
|
|
}
|
|
else {
|
|
my $valLog = (defined ($val) ? "value $val" : "undefined value");
|
|
local $SIG{__WARN__} = sub { Log3 $name, 3, "$name: PackObj pack for $objCombi " .
|
|
"$valLog with code $unpack created warning: @_"; };
|
|
my $dataPart = pack ($unpack, $val); # use unpack code, might create warnings
|
|
Log3 $name, 5, "$name: PackObj packed $valLog with pack code $unpack to " . unpack ('H*', $dataPart);
|
|
$dataPart = substr ($dataPart . pack ('x' . $len * 2, undef), 0, $len * 2); # pad with \0 bytes created by pack
|
|
Log3 $name, 5, "$name: PackObj padded / cut object to " . unpack ('H*', $dataPart);
|
|
$counter += $len;
|
|
Log3 $name, 5, "$name: PackObj revRegs = $revRegs, dplen = " . length($dataPart);
|
|
$dataPart = ReverseWordOrder($logHash, $dataPart, $len) if ($revRegs && length($dataPart) > 3);
|
|
$dataPart = SwapByteOrder($logHash, $dataPart, $len) if ($swpRegs);
|
|
$data .= $dataPart;
|
|
}
|
|
$startAdr += $len; # go to the next object
|
|
if ($counter < $valuesLen) {
|
|
Log3 $name, 5, "$name: PackObj moves to next object, skip $len to $type$startAdr, counter=$counter";
|
|
}
|
|
} # next loop round for next object
|
|
|
|
if ($type =~ /[cd]/) {
|
|
Log3 $name, 5, "$name: PackObj full bit string is $data";
|
|
$data = pack ("b$valuesLen", $data);
|
|
Log3 $name, 5, "$name: PackObj packed / cut data string is " . unpack ('H*', $data);
|
|
}
|
|
else {
|
|
Log3 $name, 5, "$name: PackObj full data string is " . unpack ('H*', $data);
|
|
# values len means registers so byte length is values len times 2
|
|
$data = substr ($data . pack ('x' . $valuesLen * 2, undef), 0, $valuesLen * 2);
|
|
Log3 $name, 5, "$name: PackObj padded / cut data string to " . unpack ('H*', $data);
|
|
}
|
|
return $data;
|
|
}
|
|
|
|
|
|
##########################################
|
|
# Pack custom fc pdu from fCode, adr, len
|
|
# and optionally the packed value
|
|
sub PackPDU {
|
|
my $hash = shift; # the logical master device to access parsing attrs
|
|
my $pduHash = shift; # pdu structure to be filled, already contains adr/len/operation/masterhash/relayhash from request
|
|
my $pduType = shift; # Request or Response for looking up attrs
|
|
my $name = $hash->{NAME}; # the name of the logical device
|
|
my $fCode = $pduHash->{FCODE};
|
|
my $cFc = 'fc' . $fCode . $pduType; # key for potential custom function code
|
|
|
|
my @fNames = split (', ', DevInfo($hash, $cFc, 'fieldList'));
|
|
my $pack = DevInfo($hash, $cFc, 'unpack', 'a*');
|
|
my @fields;
|
|
foreach my $fld (@fNames) {
|
|
my $val = $pduHash->{$fld};
|
|
my $expr = DevInfo($hash, $cFc, 'fieldExpr-'.$fld);
|
|
my $new = EvalExpr($hash, {expr => $expr, val => $val, '$pduHash' => $pduHash});
|
|
Log3 $name, 5, "$name: pack fc $fCode PDU field $fld after expr ($expr) is $new (before " . ($val // 'null') . ")";
|
|
push @fields, $new; # set pack value list according to defined fieldList
|
|
}
|
|
my $data = ($pack ne 'none') ? pack ($pack, @fields) : '';
|
|
Log3 $name, 5, "$name: pack fc $fCode PDU fields: "
|
|
. join (',', @fNames) . ' values: ' . join (',', @fields)
|
|
. ' results in packed pdu ' . unpack ('H*', pack ('C', $fCode) . $data);
|
|
return $data;
|
|
}
|
|
|
|
|
|
|
|
#######################################
|
|
# Pack request pdu from fCode, adr, len
|
|
# and optionally the packed value
|
|
sub PackRequest {
|
|
my $ioHash = shift;
|
|
my $mHash = shift;
|
|
my $request = shift // {};
|
|
my $name = $ioHash->{NAME};
|
|
my $fCode = $request->{FCODE};
|
|
my $adr = $request->{ADR};
|
|
my $len = $request->{LEN};
|
|
my $values = $request->{VALUES} // 0;
|
|
|
|
my $sHash = $mHash;
|
|
$sHash = $mHash->{CHILDOF} if ($mHash->{CHILDOF}); # take info from parent device if TCP server conn
|
|
my $lName = $sHash->{NAME}; # for looking up attrs
|
|
|
|
my $cFc = 'fc' . $fCode . 'Request'; # key for potential custom function code
|
|
|
|
#Log3 $name, 5, "$name: PackRequest called from " . FhemCaller();
|
|
my $data;
|
|
if (DevInfo($mHash, $cFc, 'unpack', 0)) { # custom fCode defined
|
|
$data = PackPDU($mHash, $request, 'Request');
|
|
}
|
|
elsif ($fCode == 1 || $fCode == 2) {
|
|
# read coils / discrete inputs, pdu: fCode, startAdr, len (=number of coils)
|
|
$data = pack ('nn', $adr, $len);
|
|
}
|
|
elsif ($fCode == 3 || $fCode == 4) {
|
|
# read holding/input registers, pdu: fCode, startAdr, len (=number of regs)
|
|
$data = pack ('nn', $adr, $len);
|
|
}
|
|
elsif ($fCode == 5) {
|
|
# write single coil, pdu: fCode, startAdr, value (1-bit as FF00)
|
|
$data = pack ('n', $adr) . $values;
|
|
}
|
|
elsif ($fCode == 6) {
|
|
# write single register, pdu: fCode, startAdr, value
|
|
$data = pack ('n', $adr) . $values;
|
|
}
|
|
elsif ($fCode == 15) {
|
|
# write multiple coils, pdu: fCode, startAdr, numOfCoils, byteCount, values
|
|
$data = pack ('nnC', $adr, $len, int($len/8)+1) . $values;
|
|
}
|
|
elsif ($fCode == 16) {
|
|
# write multiple regs, pdu: fCode, startAdr, numOfRegs, byteCount, values
|
|
$data = pack ('nnC', $adr, $len, $len*2) . $values;
|
|
}
|
|
elsif ($fCode == 999) { # raw request
|
|
# write multiple regs, pdu: values (hex)
|
|
$data = pack ('H*', $values);
|
|
return $data;
|
|
}
|
|
else {
|
|
# function code not implemented yet
|
|
Log3 $name, 3, "$name: Send function code $fCode not yet implemented";
|
|
return;
|
|
}
|
|
return pack ('C', $fCode) . $data;
|
|
}
|
|
|
|
|
|
#########################################################################
|
|
# Pack response pdu from fCode, adr, len and the packed values
|
|
# or an error pdu if $response->{ERRCODE} contains something
|
|
# called from createResponse which is called from HandleRequest as slave
|
|
# and relayRequest (for error replies)
|
|
sub PackResponse {
|
|
my $ioHash = shift;
|
|
my $lHash = shift;
|
|
my $response = shift // {};
|
|
my $name = $ioHash->{NAME};
|
|
my $fCode = $response->{FCODE};
|
|
my $adr = $response->{ADR};
|
|
my $len = $response->{LEN};
|
|
my $values = $response->{VALUES} // 0;
|
|
my $cFc = 'fc' . $fCode . 'Response'; # key for potential custom function code
|
|
|
|
Log3 $name, 5, "$name: PackResponse called from " . FhemCaller();
|
|
my $data;
|
|
if (DevInfo($lHash, $cFc, 'unpack', 0)) { # custom fCode defined
|
|
$data = PackPDU($lHash, $response, 'Response');
|
|
}
|
|
elsif ($response->{ERRCODE}) { # error PDU pdu: fCode+128, Errcode
|
|
return pack ('CC', $fCode, $response->{ERRCODE});
|
|
}
|
|
elsif ($fCode == 1 || $fCode == 2) { # read coils / discrete inputs, pdu: fCode, len (=number of bytes), coils/inputs as bits
|
|
$data = pack ('C', int($len/8)+1) . $values;
|
|
}
|
|
elsif ($fCode == 3 || $fCode == 4) { # read holding/input registers, pdu: fCode, len (=number of bytes), registers
|
|
$data = pack ('C', $len * 2) . $values;
|
|
}
|
|
elsif ($fCode == 5) { # write single coil, pdu: fCode, startAdr, coil value (1-bit as FF00)
|
|
$values = pack ('H*', $values ? 'ff00' : '0000');
|
|
$data = pack ('n', $adr) . $values;
|
|
}
|
|
elsif ($fCode == 6) { # write single register, pdu: fCode, startAdr, register value
|
|
$data = pack ('n', $adr) . $values;
|
|
}
|
|
elsif ($fCode == 15) { # write multiple coils, pdu: fCode, startAdr, numOfCoils
|
|
$data = pack ('nn', $adr, $len);
|
|
}
|
|
elsif ($fCode == 16) { # write multiple regs, pdu: fCode, startAdr, numOfRegs
|
|
$data = pack ('nn', $adr, $len);
|
|
}
|
|
elsif ($fCode == 17) { # report server id, pdu: fCode, len (=number of bytes), server id string, run indicator, optional data
|
|
$data = pack ('C', length($values)) . $values;
|
|
}
|
|
else { # function code not implemented yet
|
|
Log3 $name, 3, "$name: pack response function code $fCode not yet implemented";
|
|
return;
|
|
}
|
|
return pack ('C', $fCode) . $data;
|
|
}
|
|
|
|
|
|
#######################################
|
|
# Pack Modbus Frame
|
|
sub PackFrame {
|
|
my $hash = shift;
|
|
my $id = shift;
|
|
my $pdu = shift;
|
|
my $tid = shift;
|
|
my $name = $hash->{NAME};
|
|
my $proto = $hash->{PROTOCOL};
|
|
|
|
#Log3 $name, 5, "$name: PackFrame called from " . FhemCaller() . " id $id" .
|
|
# ($tid ? ", tid $tid" : '') . ', pdu ' . unpack ('H*', $pdu);
|
|
|
|
my $packedId = pack ('C', $id);
|
|
my $frame;
|
|
if ($proto eq 'RTU') { # RTU frame format: ID, (fCode, data), CRC
|
|
my $crc = pack ('v', CRC($packedId . $pdu));
|
|
$frame = $packedId . $pdu . $crc;
|
|
}
|
|
elsif ($proto eq 'ASCII') { # ASCII frame format: ID, (fCode, data), LRC
|
|
my $lrc = uc(unpack ('H2', pack ('v', LRC($packedId.$pdu))));
|
|
$frame = ':' . uc(unpack ('H2', $packedId) . unpack ('H*', $pdu)) . $lrc . "\r\n";
|
|
#Log3 $name, 5, "$name: packed ASCII frame with lrc $lrc is $frame";
|
|
}
|
|
elsif ($proto eq 'TCP') { # TCP frame format: tid, 0, len, ID, (fCode, data)
|
|
my $dlen = bytes::length($pdu)+1; # length of pdu + Id
|
|
my $header = pack ('nnnC', ($tid, 0, $dlen, $id));
|
|
$frame = $header.$pdu;
|
|
}
|
|
else {
|
|
Log3 $name, 3, "$name: PackFrame got unknown protocol $proto";
|
|
}
|
|
return $frame;
|
|
}
|
|
|
|
|
|
|
|
#####################################
|
|
# send a frame string
|
|
# called from processRequestQueue, CreateResponse
|
|
# and RelayResponse
|
|
sub SendFrame {
|
|
my $ioHash = shift;
|
|
my $id = shift;
|
|
my $frame = shift;
|
|
my $logHash = shift;
|
|
my $name = $ioHash->{NAME};
|
|
|
|
Log3 $name, 5, "$name: Send called from " . FhemCaller();
|
|
|
|
if ($ioHash->{TCPServer}) {
|
|
Log3 $name, 3, "$name: Send called for TCP Server hash - this should not happen";
|
|
return;
|
|
}
|
|
|
|
if ($ioHash->{DeviceName} eq 'none') {
|
|
Log3 $name, 4, "$name: Simulate sending to none: " . ShowBuffer($ioHash, $frame);
|
|
}
|
|
elsif ($ioHash->{TCPChild}) {
|
|
# write to TCP connected modbus master / tcp client (we are modbus slave)
|
|
if (!$ioHash->{CD}) {
|
|
Log3 $name, 3, "$name: no connection to send to";
|
|
return;
|
|
}
|
|
Log3 $name, 4, "$name: Send " . ShowBuffer($ioHash, $frame);
|
|
Profiler($ioHash, 'Send');
|
|
for (;;) {
|
|
my $l = syswrite($ioHash->{CD}, $frame);
|
|
last if(!$l || $l == length($frame));
|
|
$frame = substr($frame, $l);
|
|
}
|
|
$ioHash->{CD}->flush();
|
|
}
|
|
else {
|
|
if (!IsOpen($ioHash)) {
|
|
Log3 $name, 3, "$name: no connection to send to";
|
|
return;
|
|
}
|
|
Profiler($ioHash, 'Send');
|
|
# write to serial or TCP connected modbus slave / tcp server (we are modbus master)
|
|
DevIo_SimpleWrite($ioHash, $frame, 0);
|
|
}
|
|
|
|
my $now = gettimeofday();
|
|
$logHash->{REMEMBER}{lsend} = $now; # remember when last send to this device
|
|
$ioHash->{REMEMBER}{lsend} = $now; # remember when last send to this bus
|
|
$ioHash->{REMEMBER}{lid} = $id; # device id we talked to
|
|
$ioHash->{REMEMBER}{lname} = $name; # logical device name
|
|
return;
|
|
}
|
|
|
|
|
|
###########################################################
|
|
# create a hash with all objects / groups to be requested
|
|
sub CreateUpdateHash {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}}; # module hash
|
|
my $parseInfo = ($hash->{parseInfo} ? $hash->{parseInfo} : $modHash->{parseInfo});
|
|
my $devInfo = ($hash->{deviceInfo} ? $hash->{deviceInfo} : $modHash->{deviceInfo});
|
|
my $intvl = $hash->{Interval};
|
|
my $now = gettimeofday();
|
|
my $ignDelay = AttrVal($name, 'cacheUpdateHash', 0);
|
|
|
|
my @RawObjList;
|
|
foreach my $attribute (keys %{$attr{$name}}) { # add all reading attributes to a list unless they are also in parseInfo
|
|
if ($attribute =~ /^obj-(.*)-reading$/) {
|
|
push @RawObjList, $1 if (!$parseInfo->{$1});
|
|
}
|
|
};
|
|
push @RawObjList, keys (%{$parseInfo}); # add all parseInfo readings to the list
|
|
Log3 $name, 5, "$name: CreateUpdateHash full object list: " . join (' ', sort @RawObjList);
|
|
|
|
my @objList;
|
|
my %objHash;
|
|
my %grpHash;
|
|
foreach my $objCombi (sort compObjCombi @RawObjList) { # sorted by type+adr
|
|
my $reading = ObjInfo($hash, $objCombi, 'reading');
|
|
my $poll = ObjInfo($hash, $objCombi, 'poll');
|
|
my $group = ObjInfo($hash, $objCombi, 'group');
|
|
my $len = ObjInfo($hash, $objCombi, 'len');
|
|
my $lastRead = $hash->{lastRead}{$objCombi} // 0;
|
|
my $type = substr($objCombi, 0, 1);
|
|
my $adr = substr($objCombi, 1);
|
|
my $maxLen = DevInfo($hash, $type, 'combine', 0);
|
|
my $objText = "$objCombi len $len $reading";
|
|
my $delay = ($ignDelay ? 0 : ObjInfo($hash, $objCombi, 'polldelay')); # ignore Polldelay when caching update hash
|
|
$maxLen = 125 if ($maxLen > 125 && $type =~ /[hi]/); # max allowed combine for modbus holding registers or input
|
|
$maxLen = 2000 if ($maxLen > 2000 && $type =~ /[cd]/); # max allowed combine for coils / digital inputs
|
|
|
|
#Log3 $name, 5, "$name: CreateUpdateHash check $objCombi reading $reading, poll = $poll, polldelay = $delay, last = $lastRead";
|
|
my $groupNr;
|
|
$groupNr = $1 if ($group && $group =~ /(\d+)-(\d+)/);
|
|
if ($groupNr) { # handle group - objects to be requested together
|
|
my $objRef = $grpHash{'g'.$groupNr};
|
|
my $span = 0;
|
|
if ($objRef) {
|
|
$span = $adr - $objRef->{adr} + $len;
|
|
if ($objRef->{type} ne $type) {
|
|
Log3 $name, 3, "$name: CreateUpdateHash found incompatible types in group $groupNr (so far $objRef->{type}, now $type";
|
|
}
|
|
elsif ($objRef->{adr} > $adr) {
|
|
Log3 $name, 3, "$name: CreateUpdateHash found wrong adr sorting in group $groupNr. Old $objRef->{adr}, new $adr. Please report this bug";
|
|
}
|
|
elsif ($maxLen && $span > $maxLen) {
|
|
Log3 $name, 3, "$name: CreateUpdateHash found group $groupNr span $span is longer than defined maximum $maxLen";
|
|
}
|
|
else { # add to group
|
|
$objRef->{len} = $span;
|
|
$objRef->{groupInfo} .= ($objRef->{groupInfo} ? ' and ' : '') . $objText;
|
|
#Log3 $name, 5, "$name: CreateUpdateHash adds $objText to group $groupNr";
|
|
}
|
|
}
|
|
else { # new object for group
|
|
#Log3 $name, 5, "$name: CreateUpdateHash creates new hash for group $groupNr with $objText";
|
|
$objRef = {type => $type, adr => $adr, len => $len, reading => $reading,
|
|
groupInfo => $objText, group => $group, objCombi => 'g'.$groupNr};
|
|
$grpHash{'g'.$groupNr} = $objRef;
|
|
}
|
|
}
|
|
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)) {
|
|
$delay = 0 if ($delay eq 'once' || !$delay);
|
|
$delay = $1 * ($intvl ? $intvl : 1) if ($delay =~ /^x([0-9]+)/); # delay as multiplyer if starts with x
|
|
if ($now >= $lastRead + $delay) { # this object is due to be requested
|
|
if ($groupNr) {
|
|
$objHash{'g'.$groupNr} = $grpHash{'g'.$groupNr};
|
|
Log3 $name, 5, "$name: CreateUpdateHash will request group $groupNr because of $objText";
|
|
}
|
|
else { # no group
|
|
$objHash{$objCombi} = {objCombi => $objCombi, type => $type, adr => $adr, reading => $reading, len => $len};
|
|
Log3 $name, 5, "$name: CreateUpdateHash will request $objText";
|
|
}
|
|
}
|
|
else { # delay not over
|
|
if ($groupNr && $objHash{'g'.$groupNr}) { # but part of a group to be requested
|
|
Log3 $name, 5, "$name: CreateUpdateHash will request $reading because it is part of group $groupNr";
|
|
}
|
|
else { # delay not over and not in a group to be requested
|
|
my $passed = $now - $lastRead;
|
|
Log3 $name, 5, "$name: CreateUpdateHash will skip $reading, delay not over (delay $delay, $passed passed)";
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return \%objHash;
|
|
}
|
|
|
|
|
|
###################################
|
|
# combine objects to be requested
|
|
sub CombineUpdateHash {
|
|
my $hash = shift;
|
|
my $objHash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $nextSpan = 0;
|
|
my $reason = 'first object';
|
|
my $lastText = '';
|
|
my $nextText = '';
|
|
my $lastObj;
|
|
my $maxLen;
|
|
|
|
Log3 $name, 4, "$name: CombineUpdateHash objHash keys before combine: " . join ',', keys %{$objHash};
|
|
Log3 $name, 5, "$name: CombineUpdateHash tries to combine read commands";
|
|
|
|
COMBINELOOP:
|
|
foreach my $nextObj (sort compObjTA values %{$objHash}) { # sorting type/adr
|
|
$maxLen = DevInfo($hash, $nextObj->{type}, 'combine', 1);
|
|
next COMBINELOOP if ($maxLen < 2 || !$lastObj); # initial round or no combination wanted
|
|
$reason = '';
|
|
$lastText = $lastObj->{groupInfo} ? "$lastObj->{objCombi} len $lastObj->{len} ($lastObj->{groupInfo})"
|
|
: "$lastObj->{objCombi} len $lastObj->{len} $lastObj->{reading}";
|
|
$nextText = $nextObj->{groupInfo} ? "$nextObj->{objCombi} len $nextObj->{len} ($nextObj->{groupInfo})"
|
|
: "$nextObj->{objCombi} len $nextObj->{len} $nextObj->{reading}";
|
|
$nextSpan = ($nextObj->{adr} + $nextObj->{len}) - $lastObj->{adr}; # combined length
|
|
|
|
if (GetFC($hash, {TYPE => $nextObj->{type}, ADR => $nextObj->{adr}, LEN => $nextObj->{len}, OPERATION => 'read'}) !=
|
|
GetFC($hash, {TYPE => $lastObj->{type}, ADR => $lastObj->{adr}, LEN => $lastObj->{len}, OPERATION => 'read'})) {
|
|
|
|
$reason = "different function codes";
|
|
} elsif ($nextObj->{adr} <= $lastObj->{adr}) {
|
|
$reason = 'wrong order defined';
|
|
} elsif ($nextSpan > $maxLen) {
|
|
$reason = "span $nextSpan would be bigger than max $maxLen";
|
|
}
|
|
if (!$reason) { # do combine, no reason against it
|
|
Log3 $name, 5, "$name: CombineUpdateHash combine $lastText with $nextText to span $nextSpan, drop read for $nextObj->{objCombi}";
|
|
$lastObj->{combine} .= ($lastObj->{combine} ? ' and ' : "$lastText with ") . $nextText;
|
|
$lastObj->{span} = $nextSpan; # increase the length to include following object
|
|
delete $objHash->{$nextObj->{objCombi}}; # remove from hash
|
|
} else {
|
|
Log3 $name, 5, "$name: CombineUpdateHash cant combine $lastText with $nextText, $reason";
|
|
}
|
|
}
|
|
continue {
|
|
if ($reason) {
|
|
$nextObj->{span} = $nextObj->{len};
|
|
$lastObj = $nextObj ; # point last obj to next so combination can start with the next one
|
|
}
|
|
}
|
|
Log3 $name, 5, "$name: CombineUpdateHash keys are now " . join ',', keys %{$objHash};
|
|
my $logMsg = '';
|
|
foreach my $obj (sort compObjTA values %{$objHash}) {
|
|
#Log3 $name, 5, "$name: CombineUpdateHash logmsg obj = $obj->{objCombi} span $obj->{span} reading $obj->{reading}";
|
|
$logMsg = ($logMsg ? "$logMsg, " : '') . "$obj->{objCombi} len $obj->{span} " .
|
|
($obj->{combine} ? "(combined $obj->{combine})" : "($obj->{reading})");
|
|
}
|
|
Log3 $name, 4, "$name: GetUpdate will now create requests for $logMsg" ;
|
|
return;
|
|
}
|
|
|
|
|
|
###############################################################################
|
|
# called via internal timer from
|
|
# logical device module with
|
|
# update:name - name of logical device
|
|
#
|
|
# connection doesn't need to be open - request can just be queued
|
|
# and then processqueue will call async open and remove queue entries
|
|
# if they get too old
|
|
#
|
|
sub GetUpdate {
|
|
my $param = shift;
|
|
my ($calltype,$name) = split(':',$param);
|
|
my $hash = $defs{$name}; # logical device hash
|
|
my $now = gettimeofday();
|
|
|
|
Log3 $name, 4, "$name: GetUpdate (V$Module_Version) called from " . FhemCaller();
|
|
$hash->{'.LastUpdate'} = $now; # note that we were called - even when not as 'update' and UpdateTimer is not called afterwards
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'next') if ($calltype eq 'update');
|
|
my $msg = CheckDisable($hash);
|
|
return if ($msg);
|
|
my $ioHash = GetIOHash($hash); # only needed for profiling, availability id checked in CheckDisable
|
|
Profiler($ioHash, 'Fhem');
|
|
|
|
my $objHash;
|
|
if (!AttrVal($name, 'cacheUpdateHash', 0) || !$hash->{UPDATECACHE}) {
|
|
$objHash = CreateUpdateHash($hash);
|
|
CombineUpdateHash($hash, $objHash);
|
|
$hash->{UPDATECACHE} = $objHash;
|
|
}
|
|
else {
|
|
Log3 $name, 4, "$name: GetUpdate is using cached object list";
|
|
$objHash = $hash->{UPDATECACHE};
|
|
}
|
|
|
|
# now create the requests
|
|
foreach my $obj (sort compObjTA values %{$objHash}) { # sorted by type / adr
|
|
next if !$obj;
|
|
my $span = $obj->{span};
|
|
DoRequest($hash, {TYPE => $obj->{type}, ADR => $obj->{adr}, OPERATION => 'read', LEN => $span,
|
|
DBGINFO => "getUpdate for " .
|
|
($obj->{combine} ? "combined $obj->{combine}" : "$obj->{reading} len $obj->{len}")});
|
|
}
|
|
Profiler($ioHash, 'Idle');
|
|
return;
|
|
}
|
|
|
|
|
|
######################################################
|
|
# describe request as string
|
|
sub RequestText {
|
|
my $request = shift;
|
|
my $now = gettimeofday();
|
|
return 'request: ' .
|
|
(defined($request->{MODBUSID}) ? "id $request->{MODBUSID}" : 'unknown id' ) .
|
|
(defined($request->{OPERATION}) ? ", $request->{OPERATION}" : '') .
|
|
(defined($request->{FCODE}) ? " fc $request->{FCODE}" : ', unknown fc') .
|
|
' ' . ($request->{TYPE} // '') . ($request->{ADR} // '') .
|
|
($request->{LEN} ? ", len $request->{LEN}" : '') .
|
|
($request->{VALUES} ? ", value " . unpack('H*', $request->{VALUES}) : '') .
|
|
(defined($request->{TID}) ? ", tid $request->{TID}" : '') .
|
|
($request->{DEVHASH} && $request->{DEVHASH}{NAME} ? ", DEVHASH $request->{DEVHASH}{NAME}" : '') .
|
|
($request->{MASTERHASH} && $request->{MASTERHASH}{NAME} ? ", master device $request->{MASTERHASH}{NAME}" : '') .
|
|
($request->{RELAYHASH} && $request->{RELAYHASH}{NAME} ? ", for relay device $request->{RELAYHASH}{NAME}" : '') .
|
|
($request->{READING} ? ", reading $request->{READING}" : '') .
|
|
($request->{DBGINFO} ? " ($request->{DBGINFO})" : '') .
|
|
($request->{QUEUED} ? ', queued ' . sprintf('%.2f', $now - $request->{QUEUED}) . ' secs ago' : '') .
|
|
($request->{SENT} ? ', sent ' . sprintf('%.2f', $now - $request->{SENT}) . ' secs ago' : '');
|
|
}
|
|
|
|
|
|
######################################################
|
|
# describe response as string
|
|
sub ResponseText {
|
|
my $response = shift;
|
|
return "response: " . ($response->{MODBUSID} ? "id $response->{MODBUSID}" : 'no id') .
|
|
($response->{FCODE} ? ", fc $response->{FCODE}" : ", no fcode ") .
|
|
($response->{ERRCODE} ? ", error code $response->{ERRCODE}" : '') .
|
|
($response->{TYPE} && $response->{ADR} ? ", $response->{TYPE}$response->{ADR}" : '') .
|
|
($response->{LEN} ? ", len $response->{LEN}" : '') .
|
|
($response->{VALUES} ? ', values ' . unpack('H*', $response->{VALUES}) : '') .
|
|
(defined($response->{TID}) ? ", tid $response->{TID}" : '');
|
|
}
|
|
|
|
|
|
######################################################
|
|
# log current frame in buffer
|
|
sub FrameText {
|
|
my ($hash, $request, $response) = @_;
|
|
$request = $hash->{REQUEST} if (!$request);
|
|
$response = $hash->{RESPONSE} if (!$response);
|
|
return
|
|
($hash->{READ}{BUFFER} ? 'current frame / read buffer: ' . ShowBuffer($hash) : 'read buffer empty') .
|
|
($hash->{FRAME}{MODBUSID} ? ", id $hash->{FRAME}{MODBUSID}" : '') .
|
|
($hash->{FRAME}{FCODE} ? ", fCode $hash->{FRAME}{FCODE}" : '') .
|
|
(defined($hash->{FRAME}{TID}) ? ", tid $hash->{FRAME}{TID}" : '') .
|
|
($request ? ", \n" . RequestText($request) : '') .
|
|
($response ? ", \n" . ResponseText($response) : '') .
|
|
($hash->{FRAME}{ERROR} ? ", error: $hash->{FRAME}{ERROR}" : '');
|
|
}
|
|
|
|
|
|
######################################################
|
|
# log current frame in buffer
|
|
sub LogFrame {
|
|
my ($hash, $msg, $logLvl, $request, $response) = @_;
|
|
my $name = $hash->{NAME};
|
|
Log3 $name, $logLvl, "$name: $msg, " . FrameText($hash, $request, $response);
|
|
return;
|
|
}
|
|
|
|
|
|
######################################################
|
|
# drop current frame from buffer or clear full buffer
|
|
# called from Timeout-, Done and Error functions
|
|
# as well as ReadFn / ReadAnswer after HandleRequest / HandleResponse
|
|
sub DropFrame {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $drop = $hash->{READ}{BUFFER} // ''; # default: drop everything as master
|
|
my $rest = ''; # default
|
|
my $bLen = length($drop); # length of the buffer;
|
|
|
|
return if (!$bLen); # no buffer no drop
|
|
|
|
# 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
|
|
|
|
if ($hash->{MODE} ne 'master') {
|
|
if ($hash->{FRAME}{CHECKSUMERROR}) {
|
|
$drop = substr($hash->{READ}{BUFFER}, 0, 1);
|
|
$rest = substr($hash->{READ}{BUFFER}, 1);
|
|
}
|
|
elsif ($hash->{FRAME}{PDULEXP} && $hash->{PROTOCOL}) {
|
|
my $frLenExp = $hash->{FRAME}{PDULEXP} + $PDUOverhead{$hash->{PROTOCOL}};
|
|
if ($frLenExp < $bLen) {
|
|
$drop = substr($hash->{READ}{BUFFER}, 0, $frLenExp);
|
|
$rest = substr($hash->{READ}{BUFFER}, $frLenExp);
|
|
}
|
|
}
|
|
}
|
|
Log3 $name, 5, "$name: DropFrame called from " . FhemCaller() . " - drop " . ShowBuffer($hash, $drop) .
|
|
($rest ? ' rest ' . ShowBuffer($hash, $rest) : '');
|
|
$hash->{READ}{BUFFER} = $rest;
|
|
delete $hash->{FRAME};
|
|
return;
|
|
}
|
|
|
|
|
|
##################################################+
|
|
# add a message to the $frame->{ERROR} String
|
|
sub AddFrameError {
|
|
my $frame = shift;
|
|
my $msg = shift;
|
|
$frame->{ERROR} .= ($frame->{ERROR} ? ', ' : '') . $msg;
|
|
return;
|
|
}
|
|
|
|
|
|
##################################################################
|
|
# get end of pdu / start of lrc / crc if applicable
|
|
# check crc / lrc and set $hash->{FRAME}{CHECKSUMERR} if necessary
|
|
# leave length checking, reaction / logging / dropping
|
|
# to read function
|
|
sub CheckChecksum {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $proto = $hash->{PROTOCOL};
|
|
my $frame = $hash->{FRAME};
|
|
|
|
use bytes;
|
|
my $readLen = length($hash->{READ}{BUFFER});
|
|
delete $frame->{CHECKSUMERROR};
|
|
|
|
if ($proto eq 'RTU') {
|
|
my $frLenExp = $frame->{PDULEXP} + $PDUOverhead{$hash->{PROTOCOL}}; # everything including id to crc
|
|
# for RTU Overhead is 3 (id ... 2 Bytes CRC)
|
|
my $crcInputLen = ($readLen < $frLenExp ? $readLen : $frLenExp) - 2; # frame without 2 bytes crc
|
|
my $sent = unpack('v', substr($hash->{READ}{BUFFER}, $crcInputLen, 2));
|
|
my $calc = CRC(substr($hash->{READ}{BUFFER}, 0, $crcInputLen));
|
|
|
|
if ($calc != $sent) {
|
|
$frame->{CHECKSUMERROR} = 1;
|
|
AddFrameError($frame, 'Invalid checksum ' . unpack('H4', pack('v', $sent)) .
|
|
' received. Calculated ' . unpack('H4', pack('v', $calc)));
|
|
return 0;
|
|
}
|
|
else {
|
|
Log3 $name, 5, "$name: CheckChecksum (called from " . FhemCaller() . '): ' . unpack ('H4', pack ('v', $sent)) . ' is valid';
|
|
return 1;
|
|
}
|
|
}
|
|
elsif ($proto eq 'ASCII') {
|
|
my $frLenExp = $frame->{PDULEXP} * 2 + $PDUOverhead{$hash->{PROTOCOL}}; # everything including id and lrc
|
|
# for ASCII: Oberhead is 7 (Start:, 2 Ziffern Id, 2 Ziffern LRC, CR LF)
|
|
|
|
my $lrcInputLen = ($readLen < $frLenExp ? $readLen : $frLenExp) - 5;
|
|
# : (id id ... ) lrc lrc cr lf
|
|
|
|
my $lrcRead = substr($hash->{READ}{BUFFER}, $lrcInputLen + 1, 2);
|
|
my $lrcData = substr($hash->{READ}{BUFFER}, 1, $lrcInputLen);
|
|
my $sent = hex($lrcRead);
|
|
my $calc = LRC(pack ('H*', $lrcData));
|
|
#Log3 $name, 5, "$name: CheckChecksum readLen=$readLen, frameLen=$frLenExp (exp $frame->{PDULEXP}, " .
|
|
# "ovr $PDUOverhead{$hash->{PROTOCOL}}), lrcdata " . ShowBuffer($hash, $lrcData) .
|
|
# " and lrc " . ShowBuffer($hash, $lrcRead) .
|
|
# " calculated " . unpack ('H2', pack ('C', $calc)) .
|
|
# " Buffer " . ShowBuffer($hash);
|
|
|
|
if ($calc != $sent) {
|
|
$frame->{CHECKSUMERROR} = 1;
|
|
AddFrameError($frame, 'Invalid checksum ' . unpack('H2', pack('C', $sent)) .
|
|
' received. Calculated ' . unpack('H2', pack('C', $calc)));
|
|
return 0;
|
|
}
|
|
else {
|
|
Log3 $name, 5, "$name: CheckChecksum (called from " . FhemCaller() . '): ' .
|
|
unpack('H2', pack('C', $sent)) . ' is valid';
|
|
return 1;
|
|
}
|
|
}
|
|
elsif ($proto eq 'TCP') {
|
|
# nothing to be done.
|
|
return 1;
|
|
}
|
|
else {
|
|
Log3 $name, 3, "$name: CheckChecksum (called from " . FhemCaller() . ") got unknown protocol $proto";
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
|
|
#######################################
|
|
sub CountTimeouts {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
|
|
if ($hash->{TCPConn}) { # modbus TCP/RTU/ASCII over TCP
|
|
if ($hash->{TCPServer} || $hash->{TCPChild}) {
|
|
Log3 $name, 3, "$name: CountTimeouts called for TCP Server connection - this should not happen";
|
|
return;
|
|
}
|
|
if (!$hash->{TIMEOUTS}) {
|
|
$hash->{TIMEOUTS} = 1;
|
|
return;
|
|
}
|
|
$hash->{TIMEOUTS}++;
|
|
my $max = AttrVal($name, 'maxTimeoutsToReconnect', 0);
|
|
if ($max && $hash->{TIMEOUTS} >= $max) {
|
|
Log3 $name, 3, "$name: CountTimeouts counted $hash->{TIMEOUTS} successive timeouts, setting state to disconnected";
|
|
DevIo_Disconnected($hash); # close, set state and put on readyfnlist for reopening
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
############################################################################
|
|
# set state reading and take active / inactive into account
|
|
# open / close when when switching between active and inactive/disabled
|
|
# call instead of setting state directly
|
|
sub GoToState {
|
|
my $hash = shift;
|
|
my $setState = shift;
|
|
my $name = $hash->{NAME};
|
|
my $oldState = ReadingsVal($name, 'state', '');
|
|
my $disabled = AttrVal($name, 'disable', 0);
|
|
my $newState = $setState;
|
|
|
|
Log3 $name, 5, "$name: GoToState called from " . FhemCaller() . " with $setState";
|
|
|
|
if ($setState eq 'disabled') {
|
|
# nothing to be done here, newstate is already copied from setState
|
|
}
|
|
elsif ($setState eq 'enabled') { # attr disabled is not cleared yet here
|
|
$newState = 'active'; # enabled (disable removed) becomes active
|
|
}
|
|
elsif ($setState eq 'inactive') {
|
|
$newState = 'disabled' if ($disabled);
|
|
}
|
|
elsif ($setState eq 'active') {
|
|
$newState = 'disabled' if ($disabled);
|
|
}
|
|
elsif ($setState eq 'opened') {
|
|
# nothing to be done, never called with open
|
|
}
|
|
elsif ($setState eq 'disconnected') {
|
|
$newState = 'inactive' if ($oldState eq 'inactive');
|
|
$newState = 'disabled' if ($disabled);
|
|
}
|
|
else {
|
|
Log3 $name, 5, "$name: SetState got unknown parameter $setState";
|
|
return;
|
|
}
|
|
|
|
if ($newState =~ /inactive|disabled/) {
|
|
if ($hash->{TCPConn}) { # Modbus over TCP connection
|
|
DoClose($hash, {NOSTATE => 1}); # close, set Expect, clear Buffer
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'stop');
|
|
}
|
|
else { # connection via serial io device
|
|
UnregAtIODev($hash); # unregister at physical device because logical device is disabled
|
|
}
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'stop');
|
|
}
|
|
elsif ($newState eq 'active') {
|
|
if ($hash->{TCPConn} && !IsOpen($hash)) { # closed Modbus over TCP connection
|
|
DoOpen($hash) if !AttrVal($name, "closeAfterResponse", 0);
|
|
}
|
|
else {
|
|
my $ioHash = GetIOHash($hash); # get ioHash / check compatibility and set / register if necessary
|
|
Log3 $name, 4, "$name: " . ($ioHash ? "using $ioHash->{NAME}" : "no IODev") . " for communication";
|
|
}
|
|
if ($hash->{MODE} && $hash->{MODE} eq 'master') {
|
|
UpdateTimer($hash, \&Modbus::GetUpdate, 'start'); # set / change timer
|
|
}
|
|
}
|
|
|
|
Log3 $name, 5, "$name: SetState sets state from $oldState to $newState";
|
|
DevIo_setStates($hash, $newState);
|
|
return;
|
|
}
|
|
|
|
|
|
###############################################
|
|
# Called via InternalTimer with 'stimeout:$name'
|
|
# timer is set in ...
|
|
# if this is called, we are TCP Slave
|
|
sub ServerTimeout {
|
|
my $param = shift;
|
|
my ($error,$name) = split(':',$param);
|
|
my $hash = $defs{$name};
|
|
if ($hash) {
|
|
if ($hash->{CHILDOF}) {
|
|
my $pName = $hash->{CHILDOF}{NAME};
|
|
Log3 $pName, 4, "$pName: closing connection after inactivity" if ($pName);
|
|
}
|
|
DoClose($hash);
|
|
}
|
|
return;
|
|
};
|
|
|
|
|
|
################################################################################
|
|
# timeout waiting for a response
|
|
# Called via InternalTimer with "timeout:$name" (physical device)
|
|
# timer is set in ProcessRequestQueue only
|
|
#
|
|
# if this is called then we are Master and did send a request
|
|
# or we were used as relay forward device and did send a request
|
|
|
|
# timeout is not handled in passive mode. instead when an invalid response is detected
|
|
# the module tries to interpret it as a request as well
|
|
|
|
sub ResponseTimeout {
|
|
my $param = shift; # text:name (name of physical io device)
|
|
my ($error,$name) = split(':',$param);
|
|
my $hash = $defs{$name};
|
|
my $logLvl = AttrVal($name, 'timeoutLogLevel', 3);
|
|
my $retries = AttrVal($name, 'retriesAfterTimeout', 0);
|
|
my $request;
|
|
my $masterHash;
|
|
my $relayHash;
|
|
my $err = 'timeout waiting for reply';
|
|
|
|
if ($hash->{REQUEST}) {
|
|
$request = $hash->{REQUEST};
|
|
$masterHash = $request->{MASTERHASH}; # REQUEST stored in physical hash by ProcessRequestQueue
|
|
$relayHash = $request->{RELAYHASH};
|
|
$err .= " to fc $request->{FCODE} to id $request->{MODBUSID}, $request->{TYPE}$request->{ADR}, len $request->{LEN}";
|
|
#Log3 $name, 3, "$name: ResponseTimeout called, master was $masterHash->{NAME}" .
|
|
# ($relayHash ? " for relay $relayHash->{NAME}" : '');
|
|
}
|
|
else {
|
|
Log3 $name, 3, "$name: ResponseTimeout called but request structure doesn't exist - this error should never happen";
|
|
}
|
|
$hash->{EXPECT} = 'idle';
|
|
|
|
LogFrame($hash, 'Timeout waiting for a modbus response', $logLvl);
|
|
Statistics($hash, 'Timeouts');
|
|
CountTimeouts ($hash);
|
|
if (AttrVal($name, "showError", 0) && $err) {
|
|
readingsSingleUpdate($hash, "LAST_ERROR", $err, 1);
|
|
#Log3 $name, 5, "$name: set LAST_ERR to $err";
|
|
}
|
|
if ($request && $relayHash) { # create an error response through the relay
|
|
my $origRequest = $relayHash->{REQUEST};
|
|
if (!$origRequest->{MODBUSID}) {
|
|
Log3 $name, 4, "$name: relaying error response back failed because original request is missing. Maybe master has already closed connection to relay";
|
|
}
|
|
else {
|
|
# adjust Modbus ID for back communication
|
|
$request->{MODBUSID} = $origRequest->{MODBUSID};
|
|
$request->{TID} = ($origRequest->{TID} ? $origRequest->{TID} : 0);
|
|
Log3 $name, $logLvl, "$name: ResponseTimeout sends error messsage back to id $request->{MODBUSID}" .
|
|
($request->{TID} ? ", tid $request->{TID}" : '');
|
|
|
|
my $reIoHash = GetIOHash($relayHash); # the physical hash of the relay that received the original request
|
|
|
|
if (!$reIoHash) {
|
|
Log3 $name, $logLvl, "$name: sending timout response back failed because relay slave (=server) side io device disappeared";
|
|
}
|
|
else {
|
|
$request->{ERRCODE} = 11; # gw target failed to respond ($hash->{REQUEST} is a copy of the original request)
|
|
CreateResponse($reIoHash, $relayHash, $request); # create and send an error response, don't pack values since ERRCODE is set
|
|
}
|
|
}
|
|
if ($retries != 0) {
|
|
Log3 $name, 4, "$name: ResponseTimeout ignores retriesAfterTimeout because the request was relayed";
|
|
$retries = 0; # don't retry as a relay
|
|
}
|
|
}
|
|
Profiler($hash, 'Idle');
|
|
DropFrame($hash); # drop $hash->{FRAME} and the relevant part of $hash->{READ}{BUFFER}
|
|
delete $hash->{nextTimeout};
|
|
|
|
if ($hash->{MODE} eq 'master') { # close after last response in queue
|
|
if (AttrVal($name, 'closeAfterResponse', 0) && ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0) == 0) {
|
|
Log3 $name, 4, "$name: Timeout will close because closeAfterResponse is set and queue is empty";
|
|
DoClose($hash);
|
|
}
|
|
elsif (AttrVal($name, 'closeAfterResponse', 0) == 2) { # close after each response regardless of remaining queue entries
|
|
Log3 $name, 4, "$name: HandleResponse will close because closeAfterResponse is 2";
|
|
DoClose($hash, {KEEPQUEUE => 1});
|
|
}
|
|
}
|
|
|
|
$hash->{RETRY} = ($hash->{RETRY} ? $hash->{RETRY} : 0); # deleted in doRequest and handleResponse
|
|
if ($hash->{RETRY} < $retries && $request) { # retry?
|
|
$hash->{RETRY}++;
|
|
Log3 $name, 4, "$name: retry last request, retry counter $hash->{RETRY}";
|
|
$request->{FRONT} = 1; # put this retry in the front of the queue but don't sleep if delay is necessary
|
|
QueueRequest($hash, $request);
|
|
}
|
|
else {
|
|
delete $hash->{REQUEST};
|
|
delete $hash->{RETRY};
|
|
}
|
|
StartQueueTimer($hash, \&Modbus::ProcessRequestQueue, {delay => 0}); # call processRequestQueue at next possibility if appropriate
|
|
return;
|
|
};
|
|
|
|
|
|
###############################################################
|
|
# Check if connection through IO Dev is not disabled
|
|
# and call open (force) if necessary for prioritized get / set
|
|
# and potentially take over last read with readAnswer
|
|
#
|
|
# if non prioritized get / set (parameter async = 1)
|
|
# we leave the connection management to ready and processRequestQueue
|
|
#
|
|
sub GetSetChecks {
|
|
my $hash = shift;
|
|
my $async = shift;
|
|
my $name = $hash->{NAME};
|
|
my $force = !$async;
|
|
my $msg = CheckDisable($hash);
|
|
if (!$msg) {
|
|
if (!$hash->{MODE} || !$hash->{PROTOCOL} || $hash->{MODE} ne 'master') {
|
|
$msg = 'only possible as Modbus master';
|
|
}
|
|
elsif ($force) { # only check connection if not async
|
|
Log3 $name, 5, "$name: GetSetChecks with force";
|
|
|
|
my $ioHash = GetIOHash($hash); # physical hash to check busy / take over with readAnswer
|
|
if (!$ioHash) {
|
|
$msg = 'no IO device';
|
|
}
|
|
elsif (!IsOpen($ioHash)) {
|
|
DoOpen($ioHash, {FORCE => $force}); # force synchronous open unless non prioritized get / set
|
|
$msg = 'device is disconnected' if (!IsOpen($ioHash));
|
|
}
|
|
if (!$msg && $ioHash->{EXPECT} eq 'response') { # Answer for last request has not yet arrived
|
|
Log3 $name, 4, "$name: GetSetChecks calls ReadAnswer to take over async read, still waiting for response, " . FrameText($ioHash);
|
|
# no $msg because we want to continue afterwards
|
|
ReadAnswer($ioHash); # finish last read and wait for result
|
|
}
|
|
}
|
|
}
|
|
Log3 $name, 5, "$name: GetSetChecks returns " . ($msg // 'success');
|
|
return $msg;
|
|
}
|
|
|
|
|
|
############################################
|
|
# Check if disabled or IO device is disabled
|
|
sub CheckDisable {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $msg;
|
|
#Log3 $name, 5, "$name: CheckDisable called from " . FhemCaller();
|
|
|
|
if (!$hash) {
|
|
$msg = 'device is unavailable / hash is undef';
|
|
}
|
|
elsif ($hash->{TYPE} eq 'Modbus' || $hash->{TCPConn}) { # physical hash
|
|
if (IsDisabled($name)) {
|
|
$msg = 'device is disabled';
|
|
}
|
|
}
|
|
else { # this is a logical device hash
|
|
my $ioHash = GetIOHash($hash); # get physical io device hash
|
|
if (IsDisabled($name)) {
|
|
$msg = 'device is disabled';
|
|
} elsif (!$ioHash) {
|
|
$msg = 'no IO Device to communicate through';
|
|
} elsif (IsDisabled($ioHash->{NAME})) {
|
|
$msg = 'IO device is disabled';
|
|
}
|
|
}
|
|
Log3 $name, 5, "$name: CheckDisable called from " . FhemCaller() . " returns $msg" if ($msg);
|
|
return $msg;
|
|
}
|
|
|
|
|
|
################################################################
|
|
# set the $hash->{IODev} pointer to the physical io device
|
|
# and register there
|
|
# check the name passed or the IODev attr or search for device
|
|
#
|
|
# called from GetIOHash with the logical hash or from attr IODev
|
|
################################################################
|
|
sub SetIODev {
|
|
my $hash = shift; # the logical device hash
|
|
my $name = $hash->{NAME}; # name of the logical device
|
|
my $ioName = shift // AttrVal($name, 'IODev', ''); # the name of the desired io dev
|
|
my $id = $hash->{MODBUSID};
|
|
my $ioHash;
|
|
|
|
return $hash if ($hash->{TCPConn});
|
|
Log3 $name, 5, "$name: SetIODev called from " . FhemCaller();
|
|
if ($ioName) { # if we have a name (passed or from attribute), check its usability
|
|
if (!$defs{$ioName}) {
|
|
Log3 $name, 3, "$name: SetIODev from $name to $ioName but $ioName does not exist (yet?)";
|
|
}
|
|
elsif (CheckIOCompat($hash, $defs{$ioName}, 3)) {
|
|
$ioHash = $defs{$ioName}; # ioName can be used as io device, set hash
|
|
}
|
|
}
|
|
if (!$ioHash && !$ioName) { # if no attr and no name passed search for usable io device
|
|
DEVLOOP:
|
|
for my $p (sort { $defs{$b}{NR} <=> $defs{$a}{NR} } keys %defs) {
|
|
if (CheckIOCompat($hash, $defs{$p}, 5)) {
|
|
$ioHash = $defs{$p};
|
|
last DEVLOOP;
|
|
}
|
|
}
|
|
}
|
|
if (!$ioHash) { # nothing found -> give up for now
|
|
Log3 $name, 3, "$name: SetIODev found no usable physical modbus device";
|
|
DevIo_setStates($hash, 'disconnected'); # set state
|
|
UnregAtIODev($hash);
|
|
delete $hash->{IODev};
|
|
return;
|
|
}
|
|
RegisterAtIODev($hash, $ioHash); # register, set MODE and PROTOCOL
|
|
DevIo_setStates($hash, 'opened'); # set initial state for logical device connected through physical serial device like DevIo would do it after open
|
|
return $ioHash;
|
|
}
|
|
|
|
|
|
#####################################################################
|
|
# called from logical device fuctions with log dev hash
|
|
# to get the physical io device hash which should be
|
|
# stored in $hash->{IODev} (fhem.pl sets this when IODev attr is set)
|
|
# or find suitable io dev, register there
|
|
# and reconstruct this pointer by calling SetIODev if necessary
|
|
#
|
|
# called from many LD functions like get, set, getUpdate, send, ...
|
|
#####################################################################
|
|
sub GetIOHash {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME}; # name of logical device
|
|
#Log3 $name, 5, "$name: GetIOHash called from " . FhemCaller();
|
|
|
|
return $hash if ($hash->{TCPConn}); # for TCP/IP connected devices ioHash = hash
|
|
return $hash if ($hash->{TYPE} eq 'Modbus'); # this is already the physical device!
|
|
return $hash->{IODev} if ($hash->{IODev}
|
|
&& IsRegisteredAtIODev($hash, $hash->{IODev})); # $hash->{IODev} is set correctly and registerd
|
|
|
|
Log3 $name, 4, "$name: GetIOHash (called from " . FhemCaller() .
|
|
") did not find valid IODev hash key, calling SetIODev now";
|
|
return $hash->{IODev} if (SetIODev($hash)); # reconstruct pointer to physical device
|
|
#Log3 $name, 4, '$name: GetIOHash did not find IODev attribute or matching physical serial Modbus device';
|
|
return;
|
|
}
|
|
|
|
|
|
#####################################################################
|
|
# Check if $ioHash can be used as IODev for $hash
|
|
# return 1 if ok, log if not
|
|
#####################################################################
|
|
sub CheckIOCompat {
|
|
my $hash = shift;
|
|
my $ioHash = shift;
|
|
my $logLvl = shift;
|
|
my $name = $hash->{NAME}; # name of logical device
|
|
my $ioName = $ioHash->{NAME}; # name of physical device
|
|
my $id = $hash->{MODBUSID}; # Modbus id of logical device
|
|
my $msg = '';
|
|
|
|
return 1 if ($hash->{TCPConn}); # for TCP/IP connected devices ioHash = hash so everything is fine
|
|
return if (!$ioHash || !$id || $ioHash->{TYPE} ne 'Modbus');
|
|
if (!$hash->{PROTOCOL}) {
|
|
$msg = "$name doesn't have a protocol set";
|
|
}
|
|
elsif (!$hash->{MODE}) {
|
|
$msg = "$name doesn't have a mode set";
|
|
}
|
|
elsif ($ioHash->{PROTOCOL} && $ioHash->{PROTOCOL} ne $hash->{PROTOCOL}) {
|
|
$msg = "$ioName is locked to protocol $ioHash->{PROTOCOL} by " .
|
|
DevLockingKey($ioHash, 'PROTOCOL');
|
|
}
|
|
elsif ($ioHash->{MODE} && $ioHash->{MODE} ne $hash->{MODE}) {
|
|
$msg = "$ioName is locked to mode $ioHash->{MODE} by " .
|
|
DevLockingKey($ioHash, 'MODE');
|
|
}
|
|
elsif ($ioHash->{MODE} && $ioHash->{MODE} ne 'master') { # check that no other device has registered this id (unless master)
|
|
for my $ld (keys %{$ioHash->{defptr}}) { # for each registered logical device
|
|
if ($ld ne $name && $defs{$ld} && $defs{$ld}{MODBUSID} == $id) {
|
|
$msg = "$ioName has already registered id $id for $ld";
|
|
}
|
|
}
|
|
}
|
|
if ($msg) {
|
|
Log3 $name, ($logLvl ? $logLvl : 5), "$name: CheckIOCompat (called from " . FhemCaller() . ") for $name and $ioName: $msg";
|
|
return;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
|
|
################################################################
|
|
# check if logical device is registered at io dev
|
|
# ony called from GetIOHash
|
|
sub IsRegisteredAtIODev {
|
|
my $hash = shift;
|
|
my $ioHash = shift;
|
|
my $name = $hash->{NAME};
|
|
|
|
return 1 if ($hash->{MODBUSID}
|
|
&& $hash->{MODBUSID} == $ioHash->{defptr}{$name}
|
|
&& $hash->{PROTOCOL} && $hash->{MODE}
|
|
&& $ioHash->{PROTOCOL} && $ioHash->{MODE}
|
|
&& $ioHash->{PROTOCOL} eq $hash->{PROTOCOL}
|
|
&& $ioHash->{MODE} eq $hash->{MODE});
|
|
return;
|
|
}
|
|
|
|
|
|
################################################################
|
|
# register / lock protocol and mode at io dev
|
|
# called from SetIODev
|
|
sub RegisterAtIODev {
|
|
my $hash = shift;
|
|
my $ioHash = shift;
|
|
my $name = $hash->{NAME};
|
|
my $id = $hash->{MODBUSID};
|
|
my $ioName = $ioHash->{NAME};
|
|
|
|
return if ($hash->{TCPConn});
|
|
Log3 $name, 4, "$name: RegisterAtIODev called from " . FhemCaller() . " registers $name at $ioName with id $id" .
|
|
($hash->{MODE} ? ", MODE $hash->{MODE}" : '') .
|
|
($hash->{PROTOCOL} ? ", PROTOCOL $hash->{PROTOCOL}" : '');
|
|
|
|
UnregAtIODev ($hash, 1); # first silently clean up existing registrations
|
|
$hash->{IODev} = $ioHash; # point internal IODev to io device hash
|
|
$ioHash->{defptr}{$name} = $id; # register logical device for given id at io
|
|
$ioHash->{PROTOCOL} = $hash->{PROTOCOL}; # lock protocol and mode
|
|
$ioHash->{MODE} = $hash->{MODE};
|
|
ResetExpect($ioHash);
|
|
return;
|
|
}
|
|
|
|
|
|
################################################################
|
|
# unregister / unlock protocol and mode at io dev
|
|
# to be called when MODBUSID or IODEv changes
|
|
# or when device is deleted
|
|
# see attr, notify or directly from undef
|
|
################################################################
|
|
sub UnregAtIODev {
|
|
my $hash = shift;
|
|
my $silent = shift;
|
|
my $name = $hash->{NAME};
|
|
my $id = $hash->{MODBUSID};
|
|
return if ($hash->{TCPConn});
|
|
Log3 $name, 5, "$name: UnregAtIODev called from " . FhemCaller() if (!$silent);
|
|
|
|
DEVLOOP:
|
|
for my $d (values %defs) { # go through all physical Modbus devices
|
|
next DEVLOOP if ($d->{TYPE} ne 'Modbus');
|
|
my $protocolCount = 0;
|
|
my $modeCount = 0;
|
|
for my $ld (keys %{$d->{defptr}}) { # and logical devices registered there with their ids
|
|
my $ldev = $defs{$ld};
|
|
if ($ldev && $ld eq $name) { # the one to be unregistered
|
|
Log3 $name, 5, "$name: UnregAtIODev is removing $name from registrations at $d->{NAME}"
|
|
if (!$silent);
|
|
delete $d->{defptr}{$name}; # delete id as key pointing to $hash if found
|
|
}
|
|
else { # another logical device registered at $d
|
|
if ($ldev && $ldev->{PROTOCOL} eq $d->{PROTOCOL}) {
|
|
$protocolCount++;
|
|
} else {
|
|
Log3 $name, 4, "$name: UnregAtIODev called from " . FhemCaller() . " found device $ld" .
|
|
" with protocol $ldev->{PROTOCOL} registered at $d->{NAME} with protocol $d->{PROTOCOL}." .
|
|
' This should not happen';
|
|
}
|
|
if ($ldev->{MODE} eq $d->{MODE}) {
|
|
$modeCount++;
|
|
} else {
|
|
Log3 $name, 4, "$name: UnregAtIODev called from " . FhemCaller() . " found device $ld" .
|
|
" with mode $ldev->{MODE} registered at $d->{NAME} with mode $d->{MODE}." .
|
|
' This should not happen';
|
|
}
|
|
}
|
|
}
|
|
if (!$protocolCount && !$modeCount) {
|
|
Log3 $name, 5, "$name: UnregAtIODev is removing locks at $d->{NAME}" if (!$silent);
|
|
delete $d->{PROTOCOL};
|
|
delete $d->{MODE};
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
#########################################################################
|
|
# called from HandleRequest / HandleResponse with Modbus ID
|
|
# to get logical device hash responsible for this Id
|
|
#
|
|
# The Id passed here (from a received Modbus frame) is looked up
|
|
# in the table of registered logical devices.
|
|
# for requests this is the way to find the right logical device hash
|
|
#
|
|
# for responses it should match the id of the request sent/seen before
|
|
#
|
|
# The logical device hash pointed to should have this id set as well
|
|
# and if it is TCP connected, the logical hash is also the physical
|
|
#
|
|
# idea: pass mode required (master or slave/relay?) ??
|
|
sub GetLogHash {
|
|
my $ioHash = shift;
|
|
my $Id = shift;
|
|
my $name = $ioHash->{NAME}; # name of physical device
|
|
my $logHash;
|
|
my $logName;
|
|
|
|
if ($ioHash->{TCPConn}) {
|
|
$logHash = $ioHash; # Modbus TCP/RTU/ASCII over TCP, physical hash = logical hash
|
|
}
|
|
else {
|
|
for my $ld (keys %{$ioHash->{defptr}}) { # for each registered logical device
|
|
$logHash = $defs{$ld} if ($ioHash->{defptr}{$ld} == $Id);
|
|
}
|
|
if (!$logHash) {
|
|
for my $d (values %defs) { # go through all physical Modbus devices and look for a suitable one
|
|
if ($d->{TYPE} ne 'Modbus' && $d->{MODULEVERSION} && $d->{MODULEVERSION} =~ /^Modbus /
|
|
&& $d->{MODBUSID} eq $Id && $d->{PROTOCOL} eq $ioHash->{PROTOCOL} && $d->{MODE} eq $ioHash->{MODE}) {
|
|
$logHash = $d;
|
|
Log3 $name, 3, "$name: GetLogHash called from " . FhemCaller() .
|
|
' found logical device by searching! This should not happen';
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if (!$logHash) {
|
|
Log3 $name, 5, "$name: GetLogHash didnt't find a logical device for Modbus id $Id";
|
|
return;
|
|
}
|
|
$logName = $logHash->{NAME}; # don't refer to parent - we need to focus on the right connection
|
|
if ($logHash->{MODBUSID} != $Id) {
|
|
Log3 $name, 3, "$name: GetLogHash called from " . FhemCaller() . " detected wrong Modbus Id $Id, expecting $logHash->{MODBUSID}";
|
|
return;
|
|
}
|
|
Log3 $name, 5, "$name: GetLogHash returns hash for device $logName" if (!$ioHash->{TCPConn});
|
|
return $logHash
|
|
}
|
|
|
|
|
|
|
|
#######################################################################################
|
|
# who locked key at iodev ?
|
|
sub DevLockingKey {
|
|
my $ioHash = shift;
|
|
my $key = shift;
|
|
|
|
foreach my $ld (keys %{$ioHash->{defptr}}) {
|
|
if ($defs{$ld} && $defs{$ld}{$key} eq $ioHash->{$key}) {
|
|
my $ioName = $ioHash->{NAME};
|
|
Log3 $ioName, 5, "$ioName: DevLockingKey found $ld to lock key $key at $ioName as $defs{$ld}{$key}";
|
|
return $ld;
|
|
}
|
|
}
|
|
return 'unknown (this should not happen)';
|
|
}
|
|
|
|
|
|
################################################################
|
|
# show buffer as hex string or ascii for Modbus ascii
|
|
sub ShowBuffer {
|
|
my $hash = shift;
|
|
my $buffer = shift // $hash->{READ}{BUFFER};
|
|
if ($hash->{PROTOCOL} && $hash->{PROTOCOL} eq 'ASCII') {
|
|
my $ret = '';
|
|
foreach my $char (split //, $buffer) {
|
|
if ($char =~ /[0-9A-Fa-f\:]/) {
|
|
$ret .= $char;
|
|
} else {
|
|
$ret .= ' \\' . ord($char) . ' ';
|
|
}
|
|
}
|
|
return $ret;
|
|
}
|
|
return unpack ('H*', $buffer);
|
|
}
|
|
|
|
|
|
################################################################
|
|
# reset EXPECT in physical device hash to initial value
|
|
sub DropBuffer {
|
|
my $hash = shift;
|
|
my $add = shift;
|
|
my $name = $hash->{NAME};
|
|
if ($hash->{READ}{BUFFER}) {
|
|
Log3 $name, 5, "$name: DropBuffer for " . FhemCaller() .
|
|
" clears the reception buffer with " . ShowBuffer($hash) .
|
|
($add ? " $add" : '');
|
|
$hash->{READ}{BUFFER} = '';
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
################################################################
|
|
# reset EXPECT in physical device hash to initial value
|
|
sub ResetExpect {
|
|
my $hash = shift;
|
|
my $add = shift;
|
|
my $name = $hash->{NAME};
|
|
my $oldE = $hash->{EXPECT} // 'undefined';
|
|
$hash->{EXPECT} = (!$hash->{MODE} || $hash->{MODE} eq 'master' ? 'idle' : 'request');
|
|
Log3 $name, 5, "$name: ResetExpect for " . FhemCaller() . " from $oldE to $hash->{EXPECT}" .
|
|
($add ? " $add" : '') if ($hash->{EXPECT} ne $oldE);
|
|
return;
|
|
}
|
|
|
|
|
|
########################################
|
|
# used for sorting and combine checking
|
|
sub compObjCombi ($$) { ## no critic - seems to be required here when used for sort
|
|
my ($a,$b) = @_;
|
|
my $aType = substr($a, 0, 1);
|
|
my $aStart = substr($a, 1);
|
|
my $bType = substr($b, 0, 1);
|
|
my $bStart = substr($b, 1);
|
|
my $result = ($aType cmp $bType);
|
|
return $result if ($result);
|
|
$result = $aStart <=> $bStart;
|
|
return $result;
|
|
}
|
|
|
|
|
|
##############################################################################
|
|
# used for sorting hashes that contain data objects for reading creation
|
|
# compare $obj{$objCombi}{group} group-order values
|
|
sub compObjGroups ($$) { ## no critic - seems to be required here when used for sort
|
|
my ($a, $b) = @_;
|
|
my $aGrp = $a->{group} // 0;
|
|
my $bGrp = $b->{group} // 0;
|
|
my ($aNr, $aPos) = ($aGrp =~ /(\d+)-(\d+)/);
|
|
my ($bNr, $bPos) = ($bGrp =~ /(\d+)-(\d+)/);
|
|
my $result = (($aNr // 0) <=> ($bNr // 0));
|
|
return $result if ($result);
|
|
$result = ($aPos // 0) <=> ($bPos // 0);
|
|
return $result if ($result);
|
|
|
|
my $aType = $a->{type} // '';
|
|
my $aStart = $a->{adr} // 0;
|
|
my $bType = $b->{type} // '';
|
|
my $bStart = $b->{adr} // 0;
|
|
$result = ($aType cmp $bType);
|
|
return $result if ($result);
|
|
$result = $aStart <=> $bStart;
|
|
return $result;
|
|
}
|
|
|
|
|
|
##############################################################################
|
|
# used for sorting hashes that contain data objects for getupdate
|
|
sub compObjTA ($$) { ## no critic - seems to be required here
|
|
my ($a, $b) = @_;
|
|
my $aType = $a->{type} // '';
|
|
my $aStart = $a->{adr} // 0;
|
|
my $bType = $b->{type} // '';
|
|
my $bStart = $b->{adr} // 0;
|
|
my $result = ($aType cmp $bType);
|
|
return $result if ($result);
|
|
$result = $aStart <=> $bStart;
|
|
return $result;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub CRC {
|
|
use bytes;
|
|
my $frame = shift;
|
|
my $crc = 0xFFFF;
|
|
my ($chr, $lsb);
|
|
for my $i (0..bytes::length($frame)-1) {
|
|
$chr = ord(bytes::substr($frame, $i, 1));
|
|
$crc ^= $chr;
|
|
for (1..8) {
|
|
$lsb = $crc & 1;
|
|
$crc >>= 1;
|
|
$crc ^= 0xA001 if $lsb;
|
|
}
|
|
}
|
|
no bytes;
|
|
return $crc;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub 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;
|
|
}
|
|
|
|
|
|
################################################
|
|
# Get obj- Attribute with potential
|
|
# leading zeros
|
|
sub ObjAttr {
|
|
my $hash = shift;
|
|
my $key = shift;
|
|
my $oName = shift;
|
|
my $name = $hash->{NAME};
|
|
my $aName = 'obj-'.$key.'-'.$oName;
|
|
return $attr{$name}{$aName} if (defined($attr{$name}{$aName}));
|
|
if ($hash->{LeadingZeros}) {
|
|
if ($key =~ /([cdih])0*([0-9]+)/) {
|
|
my $type = $1;
|
|
my $adr = $2;
|
|
while (length($adr) <= 5) {
|
|
$aName = 'obj-'.$type.$adr.'-'.$oName;
|
|
#Log3 $name, 5, "$name: ObjInfo check $aName";
|
|
return $attr{$name}{$aName}
|
|
if (defined($attr{$name}{$aName}));
|
|
$adr = '0' . $adr;
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
################################################
|
|
# Get Object Info from Attributes,
|
|
# parseInfo Hash or default from deviceInfo Hash
|
|
sub ObjInfo {
|
|
my $hash = shift; # device hash
|
|
my $key = shift; # objCombi like h123
|
|
my $oName = shift; # requested
|
|
|
|
my $defName = $attrDefaults{$oName}{devDefault};
|
|
|
|
$hash = $hash->{CHILDOF} if ($hash->{CHILDOF}); # take info from parent device if TCP conn (TCP slave)
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}};
|
|
my $parseInfo = ($hash->{parseInfo} ? $hash->{parseInfo} : $modHash->{parseInfo});
|
|
#Log3 $name, 5, "$name: ObjInfo called from " . FhemCaller() . " for $key, object $oName" .
|
|
# ($defName ? ", defName $defName" : '');
|
|
|
|
my $reading = ObjAttr($hash, $key, 'reading');
|
|
if (!defined($reading) && $parseInfo->{$key} && $parseInfo->{$key}{reading}) {
|
|
$reading = $parseInfo->{$key}{reading};
|
|
}
|
|
if (!defined($reading)) { # not even a reading attr for this key / obj
|
|
return (exists($attrDefaults{$oName}{default}) ? $attrDefaults{$oName}{default} : '');
|
|
#$reading = "unnamed-$key"; # continuing with a default reading name will result in returning the dev defaults for e.g. len which breaks splitting etc...
|
|
}
|
|
|
|
#Log3 $name, 5, "$name: ObjInfo now looks at attrs for oName $oName / reading $reading / $key";
|
|
if (defined($attr{$name})) {
|
|
# check for explicit attribute for this object
|
|
my $value = ObjAttr($hash, $key, $oName);
|
|
return $value if (defined($value));
|
|
|
|
# check for special case: attribute can be name of reading with prefix like poll-reading
|
|
return $attr{$name}{$oName.'-'.$reading}
|
|
if (defined($attr{$name}{$oName.'-'.$reading}));
|
|
}
|
|
|
|
# parseInfo for object $oName if special Fhem module using parseinfoHash
|
|
return $parseInfo->{$key}{$oName}
|
|
if (defined($parseInfo->{$key}) && defined($parseInfo->{$key}{$oName}));
|
|
|
|
# returning unnamed here creates problems because we don't know
|
|
# if a reading actually has been defined e.g. for a slave
|
|
#
|
|
#if ($oName eq 'reading') {
|
|
# Log3 $name, 5, "$name: ObjInfo called from " . FhemCaller()
|
|
# . " with $key, $oName requested, no attr reading defined, use unnamed-$key instead";
|
|
# return "unnamed-$key"; # if no attr and no parseinfo matche before
|
|
#}
|
|
|
|
# check for type entry / attr ...
|
|
if ($oName ne 'type') {
|
|
#Log3 $name, 5, "$name: ObjInfo checking types";
|
|
my $dType = ObjInfo($hash, $key, 'type'); # default (from %atrDefaults) is ***NoTypeInfo***
|
|
if ($dType ne '***NoTypeInfo***') { # assigned type for this object
|
|
#Log3 $name, 5, "$name: ObjInfo for $key and $oName found type $dType";
|
|
my $typeSpec = DevInfo($hash, "type-$dType", $oName, '***NoTypeInfo***'); # dev-type-XYZ-$oName (e.g. len)
|
|
if ($typeSpec ne '***NoTypeInfo***') {
|
|
#Log3 $name, 5, "$name: ObjInfo $dType specifies $typeSpec for $oName";
|
|
return $typeSpec;
|
|
}
|
|
# check predefined types
|
|
my $rtype = ref($builtInType{$dType});
|
|
return $builtInType{$dType}{$oName} if ($rtype eq 'HASH' && $builtInType{$dType}{$oName});
|
|
if ($rtype eq '') {
|
|
my $indirect = $builtInType{$dType};
|
|
return $builtInType{$indirect}{$oName} if ($indirect && $builtInType{$indirect} && $builtInType{$indirect}{$oName});
|
|
}
|
|
#Log3 $name, 5, "$name: ObjInfo no definition for $oName within type $dType";
|
|
}
|
|
#Log3 $name, 5, "$name: ObjInfo no type";
|
|
}
|
|
|
|
# default for object type in deviceInfo / in attributes for device / type
|
|
if ($defName) {
|
|
#Log3 $name, 5, "$name: ObjInfo checking defaults Information defname=$defName";
|
|
my $type = substr($key, 0, 1);
|
|
if (defined($attr{$name})) {
|
|
# check for explicit attribute for this object type
|
|
my $daName = 'dev-'.$type.'-'.$defName;
|
|
#Log3 $name, 5, "$name: ObjInfo checking $daName";
|
|
return $attr{$name}{$daName}
|
|
if (defined($attr{$name}{$daName}));
|
|
|
|
# check for default attribute for all object types
|
|
my $dadName = 'dev-'.$defName;
|
|
#Log3 $name, 5, "$name: ObjInfo checking $dadName";
|
|
return $attr{$name}{$dadName}
|
|
if (defined($attr{$name}{$dadName}));
|
|
}
|
|
my $devInfo = ($hash->{deviceInfo} ? $hash->{deviceInfo} : $modHash->{deviceInfo});
|
|
return $devInfo->{$type}{$defName}
|
|
if (defined($devInfo->{$type}) && defined($devInfo->{$type}{$defName}));
|
|
}
|
|
return (exists($attrDefaults{$oName}{default}) ? $attrDefaults{$oName}{default} : '');
|
|
}
|
|
|
|
|
|
################################################
|
|
# Get Type Info from Attributes,
|
|
# or deviceInfo Hash
|
|
sub DevInfo {
|
|
my $hash = shift;
|
|
my $type = shift;
|
|
my $oName = shift;
|
|
my $lastDefault = shift;
|
|
#Log3 undef, 3, "DevInfo, hash is " . ($hash ? $hash : 'undef');
|
|
return (defined($lastDefault) ? $lastDefault : '') if (!$hash); # so DevInfo can be called if $hash is undef
|
|
$hash = $hash->{CHILDOF} if ($hash->{CHILDOF}); # take info from parent if TCP server conn
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}};
|
|
my $devInfo = ($hash->{deviceInfo} ? $hash->{deviceInfo} : $modHash->{deviceInfo});
|
|
my $aName = 'dev-'.$type.'-'.$oName;
|
|
my $adName = 'dev-'.$oName;
|
|
|
|
if (defined($attr{$name})) {
|
|
return $attr{$name}{$aName} if (defined($attr{$name}{$aName})); # explicit attribute for this type
|
|
return $attr{$name}{$adName} if (defined($attr{$name}{$adName})); # default attribute for all types
|
|
}
|
|
# default for object type in deviceInfo
|
|
return $devInfo->{$type}{$oName} if (defined($devInfo->{$type}) && defined($devInfo->{$type}{$oName}));
|
|
return (defined($lastDefault) ? $lastDefault : '');
|
|
}
|
|
|
|
|
|
##################################################
|
|
# Get Type/Adr for a reading name from Attributes,
|
|
# or parseInfo Hash
|
|
# called from get and set to get objCombi for name
|
|
sub ObjKey {
|
|
my $hash = shift;
|
|
my $reading = shift // '';
|
|
return if ($reading eq '?');
|
|
$hash = $hash->{CHILDOF} if ($hash->{CHILDOF}); # take info from parent device if TCP server conn
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}};
|
|
my $parseInfo = ($hash->{parseInfo} ? $hash->{parseInfo} : $modHash->{parseInfo});
|
|
|
|
foreach my $a (keys %{$attr{$name}}) {
|
|
if ($a =~ /obj-([cdih][0-9]+)-reading/ && $attr{$name}{$a} eq $reading) {
|
|
return $1;
|
|
}
|
|
}
|
|
foreach my $k (keys %{$parseInfo}) {
|
|
return $k if ($parseInfo->{$k}{reading} && ($parseInfo->{$k}{reading} eq $reading));
|
|
}
|
|
return '';
|
|
}
|
|
|
|
|
|
# Try to call a user defined function if defined
|
|
#################################################
|
|
sub TryCall {
|
|
my ($hash, $fName, $reading, $val) = @_;
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}};
|
|
if ($modHash->{$fName}) {
|
|
my $func = $modHash->{$fName};
|
|
Log3 $name, 5, "$name: " . FhemCaller() . " is calling $fName via TryCall for reading $reading and val $val";
|
|
no strict 'refs'; ## no critic - need symbolic function name from attr
|
|
my $ret = eval { &{$func}($hash,$reading,$val) };
|
|
if( $@ ) {
|
|
Log3 $name, 3, "$name: " . FhemCaller() . " error calling $fName: $@";
|
|
return;
|
|
}
|
|
use strict 'refs';
|
|
return $ret
|
|
}
|
|
return;
|
|
}
|
|
|
|
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
|
|
|
|
<a id="Modbus"></a>
|
|
<h3>Modbus</h3>
|
|
<ul>
|
|
Modbus defines a shared modbus i/o interface and functions to be called from other logical modules / devices.
|
|
This low level module takes care of the communication with modbus devices and provides Get, Set and cyclic polling
|
|
of Readings as well as formatting and input validation functions.
|
|
The logical device modules for individual machines only need to define the supported modbus function codes and objects of the machine
|
|
with the modbus interface in data structures.
|
|
These data structures are then used by this low level module to implement Set, Get and automatic updateing of readings in a given interval.
|
|
<br>
|
|
This version of the Modbus module supports Modbus RTU and ASCII over serial / RS485 lines as well as Modbus TCP and Modbus RTU or RTU over TCP.
|
|
It defines read / write functions for Modbus holding registers, input registers, coils and discrete inputs.
|
|
<br><br>
|
|
|
|
<b>Prerequisites</b>
|
|
<ul>
|
|
<li>
|
|
This module requires the Device::SerialPort or Win32::SerialPort module.
|
|
</li>
|
|
</ul>
|
|
<br>
|
|
|
|
<a id="Modbus-define"></a>
|
|
<b>Define</b>
|
|
<ul>
|
|
<code>define <name> Modbus <device> </code>
|
|
<br><br>
|
|
A define of a low level io device based on this module is only necessary if a shared device like a RS485 USB adapter is used
|
|
or if you need to pass several logical connections through a shared tcp connection e.g. to a gateway.
|
|
This module will also be used as a library for other high level modules that define all the data objects.
|
|
<br>
|
|
Example:<br>
|
|
<br>
|
|
<ul><code>define ModBusLine Modbus /dev/ttyUSB1@9600</code></ul>
|
|
<br>
|
|
In this example the module opens the given serial interface and other logical modules can access several Modbus devices connected to this bus concurrently.
|
|
If your device needs special communications parameters like even parity you can add the number of data bits, the parity and the number of stopbits separated by commas after the baudrate e.g.:
|
|
<br>
|
|
<ul><code>define ModBusLine Modbus /dev/ttyUSB2@38400,8,E,2</code></ul>
|
|
<br>
|
|
</ul>
|
|
<br>
|
|
|
|
<a id="Modbus-set"></a>
|
|
<b>Set-Commands</b><br>
|
|
<ul>
|
|
this low level device module doesn't provide set commands for itself but implements set
|
|
for logical device modules that make use of this module. See ModbusAttr for example.
|
|
</ul>
|
|
<br>
|
|
|
|
<a id="Modbus-get"></a>
|
|
<b>Get-Commands</b><br>
|
|
<ul>
|
|
this low level device module doesn't provide get commands for itself but implements get
|
|
for logical device modules that make use of this module.
|
|
</ul>
|
|
<br>
|
|
|
|
<a id="Modbus-attr"></a>
|
|
<b>Attributes</b><br><br>
|
|
<ul>
|
|
<li><a href="#do_not_notify">do_not_notify</a>
|
|
</li>
|
|
<li><a href="#readingFnAttributes">readingFnAttributes</a>
|
|
</li>
|
|
<br>
|
|
<li><a id="Modbus-attr-queueMax">queueMax</a><br>
|
|
max length of the queue used for sending requests, defaults to 200.
|
|
</li>
|
|
<li><a id="Modbus-attr-queueDelay">queueDelay</a><br>
|
|
modify the delay used when sending requests to the device from the internal queue, defaults to 1 second
|
|
</li>
|
|
<li><a id="Modbus-attr-queueTimeout">queueTimeout</a><br>
|
|
modify the timeout used to remove old entries in the send queue for requests. By default entries that cound not be sent for more than 20 seconds will be deleted from the queue
|
|
</li>
|
|
<li><a id="Modbus-attr-enableQueueLengthReading">enableQueueLengthReading</a><br>
|
|
if set to 1 the physical device will create a reading with the length of the queue used internally to send requests.<br>
|
|
|
|
</li>
|
|
<li><a id="Modbus-attr-busDelay">busDelay</a><br>
|
|
defines a delay that is always enforced between the last read from the bus and the next send to the bus for all connected devices
|
|
</li>
|
|
<li><a id="Modbus-attr-clientSwitchDelay">clientSwitchDelay</a><br>
|
|
defines a delay that is always enforced between the last read from the bus and the next send to the bus for all connected devices but only if the next send goes to a different device than the last one
|
|
</li>
|
|
<li><a id="Modbus-attr-frameGap">frameGap</a><br>
|
|
defines the time after which the read buffer is discarded if no frame has been received. This defaults to 1.5 seconds.
|
|
</li>
|
|
<li><a id="Modbus-attr-dropQueueDoubles">dropQueueDoubles</a><br>
|
|
prevents new request to be queued if the same request is already in the send queue
|
|
</li>
|
|
<li><a id="Modbus-attr-retriesAfterTimeout">retriesAfterTimeout</a><br>
|
|
defines how often the module will try to resend a request after a timeout. This defaults to 0
|
|
</li>
|
|
<li><a id="Modbus-attr-maxTimeoutsToReconnect">maxTimeoutsToReconnect</a><br>
|
|
defines that the module will disconnect and reconnect a connection after the given number of successive timeouts
|
|
</li>
|
|
<li><a id="Modbus-attr-timeoutLogLevel">maxTimeoutstimeoutLogLevelToReconnect</a><br>
|
|
defines at which log level timeout messages will be logged. It defaults to 3 and could e.g. be set to 4.
|
|
</li>
|
|
<li><a id="Modbus-attr-closeAfterResponse">closeAfterResponse</a><br>
|
|
if this attribute is set to 1 then the module will only open a connection when it needs to send a request.
|
|
After receiving the response the connection is closed unless the send queue contains more requests to be sent.
|
|
This might be helpful if modbus TCP slaves have to be queried by multiple masters but the slave is unable to handle more than one connection at a time.
|
|
</li>
|
|
<li><a id="Modbus-attr-nextOpenDelay">nextOpenDelay</a><br>
|
|
delay in seconds that is passed to DevIo. It is enforced between successive calls to DevIo_Open.
|
|
</li>
|
|
<li><a id="Modbus-attr-nextOpenDelay2">nextOpenDelay2</a><br>
|
|
delay in seconds to override nextOpenDelay in DevIo. This delay is enforced inside to Modbus module. Normally this attribute should never be needed.
|
|
</li>
|
|
<li><a id="Modbus-attr-openTimeout">openTimeout</a><br>
|
|
timeout in seconds that is passed to DevIo.
|
|
</li>
|
|
<li><a id="Modbus-attr-silentReconnect">silentReconnect</a><br>
|
|
this attribute controls at what loglevel reconnect messages from devIO will be logged. Without this attribute they will be logged at level 3.
|
|
If this attribute is set to 1 then such messages will be logged at level 4.
|
|
</li>
|
|
|
|
|
|
<li><a id="Modbus-attr-skipGarbage">skipGarbage</a><br>
|
|
If the module is used as master or if it is using Modbus ASCII as protocol, then the module will skip bytes received
|
|
that can not be the start of correct frames.<br>
|
|
For Modbus ASCII it skips bytes until the expected starting byte ":" is seen.
|
|
For Modbus RTU a response has to start with the id of the request that was sent before.<br>
|
|
If set to 1 this attribute will enhance the way the module treats Modbus request frames over serial lines in passive mode and a slave.
|
|
It will then skip all bytes until a byte with a modbus id is seen that is used by a logical Fhem modbus device.
|
|
Or if the last frame was a request, then it skips everything until the modbus id of this request is seen as the start of a response.
|
|
Setting this attribuet to 1 might lead to more robustness, however when there are other slaves on the same bus, it might als create trouble when other slaves do not send responses.
|
|
<br>
|
|
</li>
|
|
|
|
<li><a id="Modbus-attr-profileInterval">profileInterval</a><br>
|
|
if set to something non zero it is the time period in seconds for which the module will create bus usage statistics.
|
|
Please note that this number should be at least twice as big as the interval used for requesting values in logical devices that use this physical device<br>
|
|
The bus usage statistics create the following readings:
|
|
<ul>
|
|
<li><b>Profiler_Delay_sum</b></li>
|
|
seconds used as delays to implement the defined delays like sendDelay and commDelay
|
|
<li><b>Profiler_Fhem_sum</b></li>
|
|
seconds spend processing in the module
|
|
<li><b>Profiler_Idle_sum</b></li>
|
|
idle time
|
|
<li><b>Profiler_Read_sum</b></li>
|
|
seconds spent reading and validating the data read
|
|
<li><b>Profiler_Send_sum</b></li>
|
|
seconds spent preparing and sending data
|
|
<li><b>Profiler_Wait_sum</b></li>
|
|
seconds waiting for a response to a request
|
|
<li><b>Statistics_Requests</b></li>
|
|
number of requests sent
|
|
<li><b>Statistics_Timeouts</b></li>
|
|
timeouts encountered
|
|
|
|
</ul>
|
|
</li>
|
|
</ul>
|
|
</ul>
|
|
|
|
=end html
|
|
=cut
|
|
|
|
|