mirror of
https://github.com/fhem/fhem-mirror.git
synced 2025-05-01 20:20:10 +00:00
edfb043a69
git-svn-id: https://svn.fhem.de/fhem/trunk/fhem@24678 2b470e98-0d58-463d-a4d8-8e2adae1ed80
927 lines
38 KiB
Perl
927 lines
38 KiB
Perl
#########################################################################
|
|
# $Id$
|
|
# Utility functions of HTTPMOD that can be uses by other Fhem modules
|
|
#
|
|
# 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: rights checking for eval
|
|
# timeout functions
|
|
#
|
|
|
|
package FHEM::HTTPMOD::Utils;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use GPUtils qw(:all);
|
|
use Time::HiRes qw(gettimeofday);
|
|
use Encode qw(decode encode);
|
|
use Scalar::Util qw(looks_like_number);
|
|
use DevIo;
|
|
|
|
use Exporter ('import');
|
|
our @EXPORT_OK = qw(UpdateTimer FhemCaller
|
|
StopQueueTimer
|
|
StartQueueTimer
|
|
ValidRegex ValidExpr
|
|
EvalExpr
|
|
FormatVal
|
|
MapConvert MapToHint
|
|
CheckRange
|
|
ReverseWordOrder
|
|
SwapByteOrder
|
|
ReadKeyValue StoreKeyValue
|
|
ManageUserAttr
|
|
MemReading
|
|
FlattenJSON
|
|
BodyDecode
|
|
IsOpen
|
|
FmtTimeMs
|
|
ReadableArray
|
|
Statistics Profiler
|
|
);
|
|
|
|
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
|
|
|
|
BEGIN {
|
|
GP_Import( qw(
|
|
Log3
|
|
RemoveInternalTimer
|
|
InternalTimer
|
|
gettimeofday
|
|
|
|
FmtDateTime
|
|
addToDevAttrList
|
|
modules
|
|
attr
|
|
ReadingsVal
|
|
ReadingsTimestamp
|
|
AttrVal
|
|
InternalVal
|
|
|
|
readingsSingleUpdate
|
|
readingsBeginUpdate
|
|
readingsBulkUpdate
|
|
readingsEndUpdate
|
|
makeReadingName
|
|
|
|
EvalSpecials
|
|
AnalyzePerlCommand
|
|
PerlSyntaxCheck
|
|
rtrim
|
|
|
|
featurelevel
|
|
|
|
DevIo_OpenDev
|
|
DevIo_SimpleWrite
|
|
DevIo_SimpleRead
|
|
DevIo_CloseDev
|
|
DevIo_IsOpen
|
|
|
|
getUniqueId
|
|
getKeyValue
|
|
setKeyValue
|
|
|
|
));
|
|
};
|
|
|
|
|
|
####################################################################################################
|
|
# set internal Timer to call GetUpdate if necessary
|
|
# at next interval. Time can be aligned (attribute TimeAlign)
|
|
# called from attr (disable, alignTime), set (interval, start), openCB,
|
|
# notify (INITIALIZED|REREADCFG|MODIFIED|DEFINED) and getUpdate
|
|
# call e.g.:
|
|
# UpdateTimer($hash, \&HTTPMOD::GetUpdate, 'next'); # set update timer for next round (now + interval)
|
|
# UpdateTimer($hash, \&HTTPMOD::GetUpdate, 'stop');
|
|
# UpdateTimer($hash, \&HTTPMOD::GetUpdate, 'start'); # first call: call asap
|
|
|
|
sub UpdateTimer {
|
|
my $hash = shift;
|
|
my $updFn = shift;
|
|
my $cmd = shift // 'next';
|
|
my $name = $hash->{NAME};
|
|
my $now = gettimeofday();
|
|
my $intvl = $hash->{Interval} // 0; # make sure module doesn't use other spelling / caps
|
|
|
|
if ($cmd eq 'stop' || !$intvl) { # stop timer
|
|
RemoveInternalTimer("update:$name");
|
|
if ($hash->{'.TRIGGERTIME'}) {
|
|
Log3 $name, 4, "$name: UpdateTimer called from " . FhemCaller() . " with cmd $cmd and interval $intvl stops timer";
|
|
delete $hash->{'.TRIGGERTIME'};
|
|
delete $hash->{'.LastUpdate'};
|
|
#delete $hash->{TRIGGERTIME_FMT};
|
|
}
|
|
return;
|
|
}
|
|
if ($cmd eq 'next') {
|
|
$hash->{'.LastUpdate'} = $now; # start timer from now, ignore potential last update time
|
|
}
|
|
my $nextUpdate;
|
|
if ($hash->{'.TimeAlign'}) { # TimeAlign: do as if interval started at time w/o drift ...
|
|
my $count = int(($now - $hash->{'.TimeAlign'}) / $intvl); # $intvl <> 0,has been checked above
|
|
$nextUpdate = $count * $intvl + $hash->{'.TimeAlign'}; # next aligned time >= now, lastUpdate doesn't matter with alignment
|
|
$nextUpdate += $intvl if ($nextUpdate <= $now); # works for initial alignment as welas for next round
|
|
}
|
|
else { # no align time -> just add the interval to now
|
|
if ($hash->{'.LastUpdate'}) {
|
|
$nextUpdate = $hash->{'.LastUpdate'} + $intvl;
|
|
}
|
|
else {
|
|
$nextUpdate = $now; # first call -> don't wait for interval to pass
|
|
}
|
|
}
|
|
$hash->{'.TRIGGERTIME'} = $nextUpdate;
|
|
#$hash->{TRIGGERTIME_FMT} = FmtDateTime($nextUpdate);
|
|
|
|
my $delay = sprintf ("%.1f", $nextUpdate - $now);
|
|
Log3 $name, 4, "$name: UpdateTimer called from " . FhemCaller() . " with cmd $cmd" .
|
|
" sets timer to call update function in $delay sec at " . FmtTimeMs($nextUpdate) . ", interval $intvl";
|
|
RemoveInternalTimer("update:$name");
|
|
InternalTimer($nextUpdate, $updFn, "update:$name", 0); # now set the timer
|
|
return;
|
|
}
|
|
|
|
|
|
######################################################
|
|
# set internal timer for next queue processing
|
|
# to now + passed delay (if delay is passed)
|
|
# if no delay is passed, use attribute queueDelay if no shorter timer is already set
|
|
#
|
|
# startQueueTimer is called from Modbus:
|
|
# - in queueRequest when something got added to the queue
|
|
# - end of get/set to set it to immediate processing
|
|
# - at the end of HandleResponse
|
|
# - in processRequestQueue to set a new delay
|
|
# - in checkDelay called from processRequestQueue
|
|
# before it returns 1 (to ask the caller to return because delay is not over yet)
|
|
# but startQueueTimer does only set the timer if the queue contains something
|
|
#
|
|
sub StartQueueTimer {
|
|
my $ioHash = shift;
|
|
my $pFunc = shift; # e.g. \&Modbus::ProcessRequestQueue
|
|
my $oRef = shift; # optional hash ref for passing options
|
|
my $name = $ioHash->{NAME};
|
|
my $delay = $oRef->{'delay'} // AttrVal($name, 'queueDelay', 1); # delay until queue processing call
|
|
my $silent = $oRef->{'silent'} // 0;
|
|
my $msg = $oRef->{'log'} // '';
|
|
my $qlen = ($ioHash->{QUEUE} ? scalar(@{$ioHash->{QUEUE}}) : 0);
|
|
|
|
if ($qlen) {
|
|
my $now = gettimeofday();
|
|
return if ($ioHash->{nextQueueRun} && $ioHash->{nextQueueRun} < $now+$delay);
|
|
Log3 $name, 5, "$name: StartQueueTimer called from " . FhemCaller() .
|
|
' sets internal timer to process queue in ' .
|
|
sprintf ('%.3f', $delay) . ' seconds' . ($msg ? ", $msg" : '') if (!$silent);
|
|
RemoveInternalTimer ("queue:$name");
|
|
InternalTimer($now+$delay, $pFunc, "queue:$name");
|
|
$ioHash->{nextQueueRun} = $now+$delay;
|
|
}
|
|
else {
|
|
Log3 $name, 5, "$name: StartQueueTimer called from " . FhemCaller() .
|
|
' removes internal timer because queue is empty' if ($ioHash->{nextQueueRun} && !$silent);
|
|
delete $ioHash->{nextQueueRun};
|
|
RemoveInternalTimer ("queue:$name");
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
########################################################################################
|
|
# remove internal timer for next queue processing
|
|
# called at the end of open and close (initialized state, queue should be empty)
|
|
# end when queue becomes empty while processing the queue (not really ... todo:)
|
|
# when processRequestQueue gets called from fhem.pl via internal timer,
|
|
# this timer is removed internally -> only nextQueueRun is deleted in processRequestQueue
|
|
sub StopQueueTimer {
|
|
my $ioHash = shift;
|
|
my $oRef = shift; # optional hash ref for passing options
|
|
my $silent = $oRef->{'silent'} // 0;
|
|
my $name = $ioHash->{NAME};
|
|
if ($ioHash->{nextQueueRun}) {
|
|
Log3 $name, 5, "$name: StopQueueTimer called from " . FhemCaller() .
|
|
' removes internal timer for queue processing' if (!$silent);
|
|
RemoveInternalTimer ("queue:$name");
|
|
delete $ioHash->{nextQueueRun};
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
#########################################################################
|
|
# check if a regex is valid
|
|
sub ValidRegex {
|
|
my $hash = shift;
|
|
my $action = shift;
|
|
my $regex = shift;
|
|
my $name = $hash->{NAME};
|
|
|
|
# check if Regex is valid
|
|
local $SIG{__WARN__} = sub { Log3 $name, 3, "$name: $action with regex $regex created warning: @_"; };
|
|
eval {qr/$regex/}; ## no critic
|
|
if ($@) {
|
|
Log3 $name, 3, "$name: $action with regex $regex created error: $@";
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
|
|
###################################################################
|
|
# new combined function for evaluating perl expressions
|
|
# pass values via hash reference similar to fhem EvalSpecials
|
|
# together with AnalyzePerlCommands but more flexible:
|
|
#
|
|
# var names can not only start with % but also @ and $
|
|
# when a hash is passed and the target variable name starts with $
|
|
# then it is assigned the hash reference not a new copy of the hash.
|
|
# same for arrays.
|
|
#
|
|
# special keys:
|
|
# checkOnly : only do sytax check and return 1 if valid
|
|
# action : describe context for logging
|
|
#
|
|
# some variables are set by default to make use in HTTPMOD and Modbus
|
|
# easier: $val, $old, $text, $rawVal, $inCheckEval, @val
|
|
#
|
|
sub EvalExpr {
|
|
my $hash = shift; # the current device hash
|
|
my $oRef = shift; # optional hash ref for passing options and variables for use in expressions
|
|
my $name = $hash->{NAME};
|
|
my $val = $oRef->{'val'} // ''; # need input value already now as potential return value
|
|
my $checkOnly = $oRef->{'checkOnly'} // 0; # only syntax check
|
|
my $NlIfNoExp = $oRef->{'nullIfNoExp'} // 0; # return 0 if expression is missing
|
|
my $exp = $oRef->{'expr'} // ''; # the expression to be used
|
|
my $action = $oRef->{'action'} // 'perl expression eval'; # context for logging
|
|
my @val = ($val); # predefined variables, can be overwritten in %vHash
|
|
my $old = $val;
|
|
my $rawVal = $val;
|
|
my $text = $val;
|
|
return 0 if ($NlIfNoExp && !$exp);
|
|
return $val if (!$exp);
|
|
|
|
my $inCheckEval = ($checkOnly ? 0 : 1);
|
|
|
|
my $assign = 'package main; ';
|
|
foreach my $key (keys %{$oRef}) {
|
|
my $type = ref $oRef->{$key};
|
|
my $vName = substr($key,1);
|
|
my $vType = substr($key,0,1);
|
|
|
|
if ($type eq 'SCALAR') {
|
|
$assign .= "my \$$vName = \${\$oRef->{'$key'}};"; # assign ref to scalar as scalar
|
|
}
|
|
elsif ($type eq 'ARRAY' && $vType eq '$') {
|
|
$assign .= "my \$$vName = \$oRef->{'$key'};"; # assign array ref as array ref
|
|
}
|
|
elsif ($type eq 'ARRAY') {
|
|
$assign .= "my \@$vName = \@{\$oRef->{'$key'}};"; # assign array ref as array
|
|
}
|
|
elsif ($type eq 'HASH' && $vType eq '$') {
|
|
$assign .= "my \$$vName = \$oRef->{'$key'};"; # assign hash ref as hash ref
|
|
}
|
|
elsif ($type eq 'HASH') {
|
|
$assign .= "my \%$vName = \%{\$oRef->{'$key'}};"; # assign hash ref as hash
|
|
}
|
|
elsif ($type eq '' && $vType eq '$') {
|
|
$assign .= "my \$$vName = \$oRef->{'$key'};"; # assign scalar as scalar
|
|
}
|
|
}
|
|
$exp = $assign . ($checkOnly ? 'return undef;' : '') . $exp;
|
|
|
|
local $SIG{__WARN__} = sub { Log3 $name, 3, "$name: $action with expresion $exp created warning: @_"; };
|
|
my $result = eval $exp; ## no critic
|
|
if ($@) {
|
|
Log3 $name, 3, "$name: $action with expression $exp on $val created error: $@";
|
|
return 0 if ($checkOnly);
|
|
} else {
|
|
return 1 if ($checkOnly);
|
|
Log3 $name, 5, "$name: $action evaluated $exp to $result";
|
|
}
|
|
return $result;
|
|
}
|
|
|
|
|
|
###########################################################
|
|
# return the name of the caling function for debug output
|
|
sub FhemCaller {
|
|
my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = caller 2;
|
|
return 'Fhem internal timer' if ($subroutine =~ /main::HandleTimeout/);
|
|
return $1 if ($subroutine =~ /main::HTTPMOD_(.*)/);
|
|
return $1 if ($subroutine =~ /main::Modbus_(.*)/);
|
|
return $1 if ($subroutine =~ /::(.*)/);
|
|
return "$subroutine";
|
|
}
|
|
|
|
|
|
#########################################
|
|
# Try to convert a value with a map
|
|
# called from Set and FormatReading
|
|
# todo: also pass map as named parameter
|
|
sub MapConvert {
|
|
my $hash = shift;
|
|
my $oRef = shift; # hash ref for passing options and variables for use in expressions
|
|
|
|
my $map = $oRef->{'map'} // ''; # map to use
|
|
my $reverse = $oRef->{'reverse'} // 0; # use reverse map
|
|
my $action = $oRef->{'action'} // 'apply map'; # context for logging
|
|
my $UndefIfNoMatch = $oRef->{'undefIfNoMatch'} // 0; # return undef if map is not matching,
|
|
my $inVal = $oRef->{'val'}; # input value
|
|
my $name = $hash->{NAME};
|
|
|
|
return $inVal if (!$map); # don't change anyting if map is empty
|
|
|
|
$map =~ s/\s+/ /g; # substitute all \t \n etc. by one space only
|
|
if ($reverse) {
|
|
$map =~ s/([^, ][^,\$]*):([^,][^,\$]*),? */$2:$1, /g; # reverse map
|
|
}
|
|
# spaces in words allowed, separator is ',' or ':'
|
|
my $val = $inVal // '';
|
|
#my $val = decode ('UTF-8', $inVal);
|
|
$val =~ s/\s| |(\xc2\xa0)/ /g; # back to normal spaces in case it came from FhemWeb with coded Blank
|
|
my %mapHash = split (/, *|:/, $map); # reverse hash aus dem reverse string
|
|
|
|
if (defined($mapHash{$val})) { # Eintrag für den übergebenen Wert in der Map?
|
|
my $newVal = $mapHash{$val}; # entsprechender Raw-Wert für das Gerät
|
|
Log3 $name, 5, "$name: MapConvert called from " . FhemCaller() . " converted $val ($inVal) to $newVal with" .
|
|
($reverse ? " reversed" : "") . " map $map";
|
|
return $newVal;
|
|
}
|
|
else {
|
|
Log3 $name, 3, "$name: MapConvert called from " . FhemCaller() . " did not find $val ($inVal) in" .
|
|
($reverse ? " reversed" : "") . " map $map";
|
|
return if ($UndefIfNoMatch);
|
|
return $inVal;
|
|
}
|
|
}
|
|
|
|
|
|
#########################################
|
|
# called from UpdateHintList
|
|
sub MapToHint {
|
|
my $hint = shift; # create hint from map
|
|
$hint =~ s/([^,\$]+):([^,\$]+)(,?) */$2$3/g; # allow spaces in names
|
|
$hint =~ s/\s/ /g; # convert spaces for fhemweb
|
|
return $hint;
|
|
}
|
|
|
|
|
|
#####################################################################
|
|
# check that a value is in a defined range
|
|
sub CheckRange {
|
|
my $hash = shift;
|
|
my $oRef = shift; # optional hash ref for passing options and variables for use in expressions
|
|
my $val = $oRef->{'val'} // ''; # input value
|
|
my $min = $oRef->{'min'} // ''; # min value
|
|
my $max = $oRef->{'max'} // ''; # max value
|
|
my $name = $hash->{NAME};
|
|
$val =~ s/\s+//g; # remove spaces just to be sure
|
|
|
|
# if either min or max are specified, val has to be numeric
|
|
if (!looks_like_number $val && (looks_like_number $min || looks_like_number $max)) {
|
|
Log3 $name, 5, "$name: checkRange for " . FhemCaller() . " rejects $val because it is not numeric";
|
|
return;
|
|
}
|
|
if (looks_like_number $min) {
|
|
Log3 $name, 5, "$name: checkRange for " . FhemCaller() . " checks $val against min $min";
|
|
return if ($val < $min);
|
|
}
|
|
if (looks_like_number $max) {
|
|
Log3 $name, 5, "$name: checkRange for " . FhemCaller() . " checks $val against max $max";
|
|
return if ($val > $max);
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
|
|
#####################################################################
|
|
# use sprintf to format a value with a given format string
|
|
sub FormatVal {
|
|
my $hash = shift;
|
|
my $oRef = shift; # optional hash ref for passing options and variables for use in expressions
|
|
my $val = $oRef->{'val'}; # input value
|
|
my $format = $oRef->{'format'} // ''; # format string
|
|
my $name = $hash->{NAME};
|
|
|
|
return $val if (!$format);
|
|
my $newVal = sprintf($format, $val // '');
|
|
Log3 $name, 5, "$name: FormatVal for " . FhemCaller() . " formats " . ($val // 'undef') .
|
|
" with format " . ($format // 'undef') . ", result is " . ($newVal // 'undef');
|
|
return $newVal;
|
|
}
|
|
|
|
|
|
#####################################
|
|
# called from send and parse
|
|
# reverse order of word registers
|
|
sub ReverseWordOrder {
|
|
my $hash = shift; # hash only needed for logging
|
|
my $buffer = shift;
|
|
my $len = shift;
|
|
my $name = $hash->{NAME}; # name of device for logging
|
|
|
|
use bytes;
|
|
$len = length($buffer) if (!defined $len); # optional parameter
|
|
return $buffer if ($len < 2 || length ($buffer) < 3); # nothing to be done if only one register
|
|
Log3 $name, 5, "$name: ReverseWordOrder is reversing order of up to $len registers";
|
|
my $work = substr($buffer, 0, $len * 2); # the first 2*len bytes of buffer
|
|
my $rest = substr($buffer, $len * 2); # everything after len
|
|
|
|
my $new = '';
|
|
while ($work) {
|
|
$new = substr($work, 0, 2) . $new; # prepend first two bytes of work to new
|
|
$work = substr($work, 2); # remove first word from work
|
|
}
|
|
my $newBuffer = $new . $rest;
|
|
Log3 $name, 5, "$name: ReverseWordOrder for " . FhemCaller() . " is transforming "
|
|
. unpack ('H*', $buffer) . " to " . unpack ('H*', $newBuffer);
|
|
return $newBuffer;
|
|
}
|
|
|
|
|
|
#####################################
|
|
# called from send and parse
|
|
# reverse byte order in word registers
|
|
sub SwapByteOrder {
|
|
my $hash = shift; # hash only needed for logging
|
|
my $buffer = shift;
|
|
my $len = shift;
|
|
my $name = $hash->{NAME}; # name of device for logging
|
|
|
|
use bytes;
|
|
$len = length($buffer) if (!defined $len); # optional parameter
|
|
Log3 $name, 5, "$name: SwapByteOrder is reversing byte order of up to $len registers";
|
|
my $rest = substr($buffer, $len * 2); # everything after len
|
|
my $nval = '';
|
|
for (my $i = 0; $i < $len; $i++) {
|
|
$nval = $nval . substr($buffer,$i*2 + 1,1) . substr($buffer,$i*2,1);
|
|
};
|
|
my $newBuffer = $nval . $rest;
|
|
Log3 $name, 5, "$name: SwapByteOrder for " . FhemCaller() . " is transforming "
|
|
. unpack ('H*', $buffer) . " to " . unpack ('H*', $newBuffer);
|
|
return $newBuffer;
|
|
}
|
|
|
|
|
|
############################################################################
|
|
# set userAttr-Attribute for Regex-Attrs
|
|
# with recent version of fhem userattrs are no longer needed
|
|
# to edit them or match hints.
|
|
# so remove all userattr entries for regex attrs
|
|
# unless their hint is different from the one in the modules list
|
|
#
|
|
# pass device hash and new attr based on a regex attr
|
|
sub ManageUserAttr {
|
|
my $hash = shift;
|
|
my $aName = shift;
|
|
my $name = $hash->{NAME};
|
|
my $modHash = $modules{$hash->{TYPE}};
|
|
|
|
if ($modHash->{AttrList} =~ m{ (?:\A|\s) # Beginning or space
|
|
$aName # the name of the new attribute
|
|
(?: \s | \: | \z) # space, : or the end
|
|
}xms) { # does AttrList contain the passed attribute (potentially with an added hint) -> no regex attr?
|
|
my $retVal;
|
|
if ($aName =~ m{ \| \* \+ \[}xms) { # contained in list -> make sure nobody tries to set it as regex attr
|
|
$retVal = "$name: Atribute $aName is not valid. It still contains wildcard symbols";
|
|
Log3 $name, 3, $retVal;
|
|
}
|
|
return $retVal;
|
|
}
|
|
#Log3 $name, 5, "$name: ManageUserAttr for $aName called from " . FhemCaller(). ", userattr = " . ($attr{$name}{userattr} // '');
|
|
|
|
MODATTRLOOP: # find the corresponding attr in the modules attrlist
|
|
foreach my $listAttr (split " ", $modHash->{AttrList}) { # go through all possible attrs in the module's list and check if the passed attr matches one of the regex attrs
|
|
my ($listAttrName, $listAttrHint)
|
|
= $listAttr =~ m{ \A ([^:]+) (:?.*) }xms; # split module attr list entry in name and optional hint
|
|
if ($aName =~ m{\A$listAttrName\z}xms) { # yes - the passed attribute name now matches the entry in the list as regex
|
|
# found regex attr in modules list that belongs to $aName, saved in $listAttrName and $listAttrHint
|
|
my $uaList = $attr{$name}{userattr} // ''; # get the userAttr list
|
|
my %uaHash;
|
|
my $found = 0;
|
|
|
|
UALOOP:
|
|
foreach my $userAttr (split(" ", $uaList)) { # for every userAttr
|
|
my ($userAttrName, $userAttrHint)
|
|
= $userAttr =~ m{ \A ([^:]+) (:?.*) }xms; # split user attr list entry in name and optional hint
|
|
#Log3 $name, 5, "$name: ManageUserAttr compares userattr name $userAttrName with passed attr name $aName";
|
|
if ($userAttrName eq $aName) {
|
|
#Log3 $name, 5, "$name: ManageUserAttr compares hints from userattr $userAttrHint with hint from list $listAttrHint";
|
|
$found = 1;
|
|
if ($userAttrHint && $userAttrHint ne ($listAttrHint // '')) {
|
|
$uaHash{$userAttr} = 1; # keep $userAttr with hint if module attr has different or no hint
|
|
#Log3 $name, 5, "$name: ManageUserAttr keeps userattr $userAttr with different hint";
|
|
}
|
|
} else {
|
|
$uaHash{$userAttr} = 1; # keep userattr with different names
|
|
#Log3 $name, 5, "$name: ManageUserAttr keeps other existing userattr $userAttr";
|
|
}
|
|
}
|
|
# this code is no longer necessary - fhem recognizes hints from regex attrs by itself now
|
|
#if (!$found && $listAttrHint) { # add userAttr with attr from module list
|
|
# $uaHash{$aName . $listAttrHint} = 1;
|
|
# #Log3 $name, 5, "$name: ManageUserAttr adds $aName$listAttrHint";
|
|
#}
|
|
my $aString = join(" ", sort keys %uaHash); # reconstruct userAttr list string
|
|
if ($aString) {
|
|
$attr{$name}{userattr} = $aString;
|
|
Log3 $name, 5, "$name: ManageUserAttr updated userattr list to $aString";
|
|
} else {
|
|
if ($attr{$name}{userattr}) {
|
|
Log3 $name, 3, "$name: ManageUserAttr removed useless userattr list";
|
|
delete $attr{$name}{userattr};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
###################################################
|
|
# checks and stores obfuscated keys like passwords
|
|
# based on / copied from FRITZBOX_storePassword
|
|
sub StoreKeyValue {
|
|
my $hash = shift;
|
|
my $kName = shift;
|
|
my $value = shift;
|
|
|
|
my $index = $hash->{TYPE}."_".$hash->{NAME}."_".$kName;
|
|
my $key = getUniqueId().$index;
|
|
my $enc = "";
|
|
|
|
if(eval "use Digest::MD5; 1") {
|
|
$key = Digest::MD5::md5_hex(unpack "H*", $key);
|
|
$key .= Digest::MD5::md5_hex($key);
|
|
}
|
|
for my $char (split //, $value) {
|
|
my $encode=chop($key);
|
|
$enc.=sprintf("%.2x",ord($char)^ord($encode));
|
|
$key=$encode.$key;
|
|
}
|
|
|
|
my $err = setKeyValue($index, $enc);
|
|
return "error while saving the value - $err" if(defined($err));
|
|
return;
|
|
}
|
|
|
|
|
|
#####################################################
|
|
# reads obfuscated value
|
|
sub ReadKeyValue {
|
|
my $hash = shift;
|
|
my $kName = shift;
|
|
my $name = $hash->{NAME};
|
|
my $index = $hash->{TYPE}."_".$hash->{NAME}."_".$kName;
|
|
my $key = getUniqueId().$index;
|
|
my ($value, $err);
|
|
|
|
Log3 $name, 5, "$name: ReadKeyValue tries to read value for $kName from file";
|
|
($err, $value) = getKeyValue($index);
|
|
if ( defined($err) ) {
|
|
Log3 $name, 4, "$name: ReadKeyValue is unable to read value from file: $err";
|
|
return;
|
|
}
|
|
|
|
if ( !defined($value) ) {
|
|
Log3 $name, 4, "$name: ReadKeyValue could not find key $kName in file";
|
|
return;
|
|
}
|
|
if (eval "use Digest::MD5; 1") {
|
|
$key = Digest::MD5::md5_hex(unpack "H*", $key);
|
|
$key .= Digest::MD5::md5_hex($key);
|
|
}
|
|
my $dec = '';
|
|
for my $char (map { pack('C', hex($_)) } ($value =~ /(..)/g)) {
|
|
my $decode=chop($key);
|
|
$dec.=chr(ord($char)^ord($decode));
|
|
$key=$decode.$key;
|
|
}
|
|
return $dec;
|
|
}
|
|
|
|
|
|
|
|
###################################################
|
|
# recoursive main part for HTTPMOD_FlattenJSON($$)
|
|
# consumes a hash passed as parameter
|
|
# and creates $hash->{ParserData}{JSON}{$prefix.$key}
|
|
sub JsonFlatter {
|
|
my $hash = shift; # reference to Fhem device hash
|
|
my $ref = shift; # starting point in JSON-Structure hash
|
|
my $prefix = shift // ''; # prefix string for resulting key
|
|
my $name = $hash->{NAME}; # Fhem device name
|
|
|
|
#Log3 $name, 5, "$name: JSON Flatter called : prefix $prefix, ref is $ref";
|
|
if (ref($ref) eq "ARRAY" ) {
|
|
my $key = 0;
|
|
foreach my $value (@{$ref}) {
|
|
#Log3 $name, 5, "$name: JSON Flatter in array while, key = $key, value = $value";
|
|
if(ref($value) eq "HASH" or ref($value) eq "ARRAY") {
|
|
#Log3 $name, 5, "$name: JSON Flatter doing recursion because value is a " . ref($value);
|
|
JsonFlatter($hash, $value, $prefix.sprintf("%02i",$key+1)."_");
|
|
}
|
|
else {
|
|
if (defined ($value)) {
|
|
#Log3 $name, 5, "$name: JSON Flatter sets $prefix$key to $value";
|
|
$hash->{ParserData}{JSON}{$prefix.$key} = $value;
|
|
}
|
|
}
|
|
$key++;
|
|
}
|
|
}
|
|
elsif (ref($ref) eq "HASH" ) {
|
|
while( my ($key,$value) = each %{$ref}) {
|
|
#Log3 $name, 5, "$name: JSON Flatter in hash while, key = $key, value = $value";
|
|
if(ref($value) eq "HASH" or ref($value) eq "ARRAY") {
|
|
#Log3 $name, 5, "$name: JSON Flatter doing recursion because value is a " . ref($value);
|
|
JsonFlatter($hash, $value, $prefix.$key."_");
|
|
}
|
|
else {
|
|
if (defined ($value)) {
|
|
#Log3 $name, 5, "$name: JSON Flatter sets $prefix$key to $value";
|
|
$hash->{ParserData}{JSON}{$prefix.$key} = $value;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
####################################
|
|
# entry to create a flat hash
|
|
# out of a pares JSON hash hierarchy
|
|
sub FlattenJSON {
|
|
my $hash = shift; # reference to Fhem device hash
|
|
my $buffer = shift; # buffer containing JSON data
|
|
my $name = $hash->{NAME}; # Fhem device name
|
|
|
|
eval "use JSON";
|
|
return if($@);
|
|
|
|
my $decoded = eval { decode_json($buffer) };
|
|
my $cT = $hash->{'.Content-Type'} // '';
|
|
my $logLvl = ($cT =~ /json/i ? 3 : 4);
|
|
if ($@) {
|
|
Log3 $name, $logLvl, "$name: error while parsing JSON data: $@";
|
|
#Log3 $name, 3, "$name: Content-Type was $cT";
|
|
}
|
|
else {
|
|
JsonFlatter($hash, $decoded);
|
|
Log3 $name, 4, "$name: extracted JSON values to internal";
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
#################################################################
|
|
# create memory Reading Fhem_Mem
|
|
sub MemReading {
|
|
my $hash = shift;
|
|
my $name = $hash->{NAME}; # Fhem device name
|
|
if (-e "/proc/$$/status") {
|
|
my $v = `awk '/VmSize/{print \$2}' /proc/$$/status`;
|
|
$v = sprintf("%.2f",(rtrim($v)/1024));
|
|
readingsBeginUpdate($hash);
|
|
readingsBulkUpdate ($hash, "Fhem_Mem", $v);
|
|
readingsBulkUpdate ($hash, "Fhem_BufCounter", $hash->{BufCounter}) if defined($hash->{BufCounter});
|
|
readingsEndUpdate($hash, 1);
|
|
Log3 $name, 5, "$name: Read checked virtual Fhem memory: " . $v . "MB" .
|
|
(defined($hash->{BufCounter}) ? ", BufCounter = $hash->{BufCounter}" : "");
|
|
} else {
|
|
Log3 $name, 5, "$name: MemReading only works under Linux";
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
########################################################
|
|
# get content-type and decode charset in a http response
|
|
sub BodyDecode {
|
|
my $hash = shift;
|
|
my $body = shift;
|
|
my $header = shift // '';
|
|
my $name = $hash->{NAME}; # Fhem device name
|
|
my $bodyDecode = AttrVal($name, 'bodyDecode', 'default');
|
|
my $bodyCharset;
|
|
my $decoding;
|
|
|
|
if ($header =~/Content-Type:(.*)/i) {
|
|
$hash->{'.Content-Type'} = $1;
|
|
}
|
|
if ($header =~/Content-Type:.*charset=([\w\-\.]+)/i) {
|
|
$bodyCharset = $1;
|
|
$hash->{'.bodyCharset'} = $bodyCharset;
|
|
}
|
|
else {
|
|
$bodyCharset = 'not found';
|
|
delete $hash->{'.bodyCharset'};
|
|
}
|
|
|
|
if ($bodyDecode =~ m{\A [Nn]one \z}xms) {
|
|
Log3 $name, 4, "$name: BodyDecode is not decoding the response body (charset $bodyCharset, bodyDecode set to none)";
|
|
}
|
|
elsif ($bodyDecode eq 'default') {
|
|
Log3 $name, 4, "$name: BodyDecode is not decoding the response body (charset $bodyCharset, bodyDecode defaults to none)";
|
|
}
|
|
elsif ($bodyDecode =~ m{\A [Aa]uto \z}xms) {
|
|
if ($bodyCharset eq 'not found') {
|
|
Log3 $name, 4, "$name: BodyDecode is not decoding the response body (charset header not found, bodyDecode set to auto)";
|
|
}
|
|
else {
|
|
Log3 $name, 4, "$name: BodyDecode is decoding the response body as $bodyCharset (charset header $bodyCharset, bodyDecode set to auto)";
|
|
$decoding = $bodyCharset;
|
|
}
|
|
}
|
|
elsif (lc($bodyDecode) eq lc($bodyCharset)) {
|
|
Log3 $name, 4, "$name: BodyDecode is decoding the response body as $bodyDecode";
|
|
$decoding = $bodyCharset;
|
|
}
|
|
else {
|
|
Log3 $name, 4, "$name: BodyDecode is decoding the response body as $bodyDecode but charset header is $bodyCharset";
|
|
$decoding = $bodyDecode;
|
|
}
|
|
|
|
if ($decoding) {
|
|
$body = decode($decoding, $body);
|
|
$hash->{'.bodyCharset'} = 'internal';
|
|
#Log3 $name, 5, "$name: BodyDecode " . ($body ? "new body as utf-8 is: \n" . encode ('utf-8', $body) : "body empty");
|
|
}
|
|
return $body;
|
|
}
|
|
|
|
|
|
########################################
|
|
# check if a device is open
|
|
# not only for devio devices but also
|
|
# tcpserver
|
|
sub IsOpen {
|
|
my $hash = shift;
|
|
return 1 if ($hash->{DeviceName} eq 'none');
|
|
return 1 if ($hash->{TCPServer} && $hash->{FD});
|
|
return 1 if ($hash->{TCPChild} && defined($hash->{CD}));
|
|
return DevIo_IsOpen($hash);
|
|
}
|
|
|
|
|
|
####################################################
|
|
# format time as string with msecs as fhem.pl does
|
|
sub FmtTimeMs {
|
|
my $time = shift // 0;
|
|
my $seconds;
|
|
my $mseconds;
|
|
if ($time =~ /([^\.]+)(\.(.{0,3}))?/) {
|
|
$seconds = $1;
|
|
$mseconds = $2 // 0;
|
|
}
|
|
else {
|
|
$seconds = $time;
|
|
$mseconds = 0;
|
|
}
|
|
#my $seconds = int ($time);
|
|
#my $mseconds = $time - $seconds;
|
|
#Log3 undef, 1, "Test: ms = $mseconds";
|
|
|
|
my @t = localtime($seconds);
|
|
my $tim = sprintf("%02d:%02d:%02d", $t[2],$t[1],$t[0]);
|
|
$tim .= sprintf(".%03d", $mseconds * 1000);
|
|
return $tim;
|
|
}
|
|
|
|
|
|
#########################################################
|
|
sub ReadableArray {
|
|
my $val = shift;
|
|
my $vString = '';
|
|
foreach my $v (@{$val}) {
|
|
$vString .= ($vString eq '' ? '' : ', ') . ($v =~ /^[[:print:]]+$/ ? $v : 'hex ' . unpack ('H*', $v));
|
|
}
|
|
return $vString
|
|
}
|
|
|
|
|
|
|
|
#####################################################
|
|
# collect statistics like number of requests / errors
|
|
# in a defined interval
|
|
sub Statistics {
|
|
my $hash = shift; # our device hash
|
|
my $key = shift; # the name / key of this statistic (e.g. requests or timeouts)
|
|
my $value = shift // 1; # if no value is passed, assume 1
|
|
my $name = $hash->{NAME};
|
|
|
|
my $pInterval = AttrVal($name, 'profileInterval', 0);
|
|
return if (!$pInterval);
|
|
|
|
my $now = gettimeofday();
|
|
my $pPeriod = int($now / $pInterval);
|
|
|
|
if (!defined ($hash->{statistics}{lastPeriod}) || ($pPeriod != $hash->{statistics}{lastPeriod})) {
|
|
readingsBeginUpdate($hash);
|
|
foreach my $k (keys %{$hash->{statistics}{sums}}) {
|
|
readingsBulkUpdate($hash, 'Statistics_' . $k, $hash->{statistics}{sums}{$k});
|
|
$hash->{statistics}{sums}{$k} = 0;
|
|
}
|
|
readingsEndUpdate($hash, 1);
|
|
$hash->{statistics}{sums}{$key} = $value;
|
|
$hash->{statistics}{lastPeriod} = $pPeriod;
|
|
}
|
|
else {
|
|
if ($hash->{statistics}{sums}{$key}) {
|
|
$hash->{statistics}{sums}{$key} += $value;
|
|
} else {
|
|
$hash->{statistics}{sums}{$key} = $value;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
##############################################################
|
|
# add up time used during certain activities
|
|
# like sending, waiting for a response or reading
|
|
sub Profiler {
|
|
my $hash = shift; # device hash
|
|
my $key = shift; # key / class name to use for profiling the following time period
|
|
return if (!$hash);
|
|
my $name = $hash->{NAME};
|
|
my $pInterval = AttrVal($name, 'profileInterval', 0);
|
|
return if (!$pInterval);
|
|
my $now = gettimeofday();
|
|
my $pPeriod = int($now / $pInterval);
|
|
|
|
if (!defined ($hash->{profiler}{lastKey})) { # initialize values at first call
|
|
$hash->{profiler}{lastKey} = $key;
|
|
$hash->{profiler}{lastPeriod} = $pPeriod;
|
|
$hash->{profiler}{start}{$key} = $now;
|
|
$hash->{profiler}{sums}{$key} = 0 ;
|
|
Log3 $name, 5, "$name: Profiling $key initialized, start " . FmtTimeMs($now);
|
|
return;
|
|
}
|
|
my $lKey = $hash->{profiler}{lastKey}; # save last key
|
|
my $lDiff = ($now - $hash->{profiler}{start}{$lKey}); # time diff for last key
|
|
$lDiff = 0 if (!$hash->{profiler}{start}{$lKey});
|
|
|
|
if (!$hash->{profiler}{start}{$key}) {
|
|
$hash->{profiler}{start}{$key} = $now; # save start time for new key
|
|
}
|
|
|
|
Log3 $name, 5, "$name: Profiling $key, before $lKey, now is " . FmtTimeMs($now) .
|
|
", $key started at " . FmtTimeMs($hash->{profiler}{start}{$key}) .
|
|
", $lKey started at " . FmtTimeMs($hash->{profiler}{start}{$lKey});
|
|
|
|
if ($pPeriod != $hash->{profiler}{lastPeriod}) { # new period
|
|
my $overP = $now - ($pPeriod * $pInterval); # time over the pPeriod start
|
|
$overP = 0 if ($overP > $lDiff); # if interval was modified things get inconsistant ...
|
|
Log3 $name, 5, "$name: Profiling pPeriod changed, last pPeriod was " . $hash->{profiler}{lastPeriod} .
|
|
" now $pPeriod, total diff for $lKey is $lDiff, " .
|
|
sprintf ('%.3f', $overP) . " over the pPeriod";
|
|
Log3 $name, 5, "$name: Profiling add " . sprintf('%.3f', $lDiff - $overP) . " to sum for $key";
|
|
$hash->{profiler}{sums}{$lKey} += ($lDiff - $overP);
|
|
|
|
readingsBeginUpdate($hash);
|
|
foreach my $k (keys %{$hash->{profiler}{sums}}) {
|
|
my $val = sprintf('%.3f', $hash->{profiler}{sums}{$k});
|
|
Log3 $name, 5, "$name: Profiling set reading for $k to $val";
|
|
readingsBulkUpdate($hash, 'Profiler_' . $k . '_sum', $val);
|
|
$hash->{profiler}{sums}{$k} = 0;
|
|
$hash->{profiler}{start}{$k} = 0;
|
|
}
|
|
readingsEndUpdate($hash, 1);
|
|
|
|
$hash->{profiler}{start}{$key} = $now;
|
|
$hash->{profiler}{sums}{$lKey} = $overP;
|
|
$hash->{profiler}{lastPeriod} = $pPeriod;
|
|
$hash->{profiler}{lastKey} = $key;
|
|
Log3 $name, 5, "$name: Profiling set new sum for $lKey to " . sprintf('%.3f', $overP);
|
|
}
|
|
else {
|
|
return if ($key eq $hash->{profiler}{lastKey}); # nothing new - take time when key or pPeriod changes
|
|
Log3 $name, 5, "$name: Profiling add " . sprintf('%.3f', $lDiff) . " to sum for $lKey " .
|
|
"(now is " . FmtTimeMs($now) . ", start for $lKey was " .
|
|
FmtTimeMs($hash->{profiler}{start}{$lKey}) . ")";
|
|
$hash->{profiler}{sums}{$lKey} += $lDiff;
|
|
$hash->{profiler}{start}{$key} = $now;
|
|
$hash->{profiler}{lastKey} = $key;
|
|
}
|
|
return;
|
|
}
|
|
|
|
1;
|