mirror of
https://github.com/fhem/fhem-mirror.git
synced 2025-03-04 05:16:45 +00:00
98_HTTPMOD: bugfixes in Utils.pm
git-svn-id: https://svn.fhem.de/fhem/trunk@23331 2b470e98-0d58-463d-a4d8-8e2adae1ed80
This commit is contained in:
StefanStrobel
parent
bdaff98615
commit
29b0758fd2
@ -49,6 +49,7 @@ our @EXPORT_OK = qw(UpdateTimer FhemCaller
|
|||||||
IsOpen
|
IsOpen
|
||||||
FmtTimeMs
|
FmtTimeMs
|
||||||
ReadableArray
|
ReadableArray
|
||||||
|
Statistics Profiler
|
||||||
);
|
);
|
||||||
|
|
||||||
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
|
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
|
||||||
@ -181,12 +182,12 @@ sub StartQueueTimer {
|
|||||||
my $now = gettimeofday();
|
my $now = gettimeofday();
|
||||||
my $delay = (defined($pDelay) ? $pDelay : AttrVal($name, 'queueDelay', 1));
|
my $delay = (defined($pDelay) ? $pDelay : AttrVal($name, 'queueDelay', 1));
|
||||||
return if ($ioHash->{nextQueueRun} && $ioHash->{nextQueueRun} < $now+$delay);
|
return if ($ioHash->{nextQueueRun} && $ioHash->{nextQueueRun} < $now+$delay);
|
||||||
RemoveInternalTimer ("queue:$name");
|
|
||||||
InternalTimer($now+$delay, $pFunc, "queue:$name", 0);
|
|
||||||
$ioHash->{nextQueueRun} = $now+$delay;
|
|
||||||
Log3 $name, 5, "$name: StartQueueTimer called from " . FhemCaller() .
|
Log3 $name, 5, "$name: StartQueueTimer called from " . FhemCaller() .
|
||||||
' sets internal timer to process queue in ' .
|
' sets internal timer to process queue in ' .
|
||||||
sprintf ('%.3f', $delay) . ' seconds' . ($msg ? ", $msg" : '') if (!$silent);
|
sprintf ('%.3f', $delay) . ' seconds' . ($msg ? ", $msg" : '') if (!$silent);
|
||||||
|
RemoveInternalTimer ("queue:$name");
|
||||||
|
InternalTimer($now+$delay, $pFunc, "queue:$name");
|
||||||
|
$ioHash->{nextQueueRun} = $now+$delay;
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
Log3 $name, 5, "$name: StartQueueTimer called from " . FhemCaller() .
|
Log3 $name, 5, "$name: StartQueueTimer called from " . FhemCaller() .
|
||||||
@ -210,10 +211,10 @@ sub StopQueueTimer {
|
|||||||
my $silent = $oRef->{'silent'} // 0;
|
my $silent = $oRef->{'silent'} // 0;
|
||||||
my $name = $ioHash->{NAME};
|
my $name = $ioHash->{NAME};
|
||||||
if ($ioHash->{nextQueueRun}) {
|
if ($ioHash->{nextQueueRun}) {
|
||||||
RemoveInternalTimer ("queue:$name");
|
|
||||||
delete $ioHash->{nextQueueRun};
|
|
||||||
Log3 $name, 5, "$name: StopQueueTimer called from " . FhemCaller() .
|
Log3 $name, 5, "$name: StopQueueTimer called from " . FhemCaller() .
|
||||||
' removes internal timer for queue processing' if (!$silent);
|
' removes internal timer for queue processing' if (!$silent);
|
||||||
|
RemoveInternalTimer ("queue:$name");
|
||||||
|
delete $ioHash->{nextQueueRun};
|
||||||
}
|
}
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
@ -317,9 +318,10 @@ sub EvalExpr {
|
|||||||
# return the name of the caling function for debug output
|
# return the name of the caling function for debug output
|
||||||
sub FhemCaller {
|
sub FhemCaller {
|
||||||
my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = caller 2;
|
my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = caller 2;
|
||||||
return $1 if ($subroutine =~ /main::HTTPMOD_(.*)/);
|
|
||||||
return $1 if ($subroutine =~ /main::(.*)/);
|
|
||||||
return 'Fhem internal timer' if ($subroutine =~ /main::HandleTimeout/);
|
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";
|
return "$subroutine";
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -336,7 +338,7 @@ sub MapConvert {
|
|||||||
my $reverse = $oRef->{'reverse'} // 0; # use reverse map
|
my $reverse = $oRef->{'reverse'} // 0; # use reverse map
|
||||||
my $action = $oRef->{'action'} // 'apply map'; # context for logging
|
my $action = $oRef->{'action'} // 'apply map'; # context for logging
|
||||||
my $UndefIfNoMatch = $oRef->{'undefIfNoMatch'} // 0; # return undef if map is not matching,
|
my $UndefIfNoMatch = $oRef->{'undefIfNoMatch'} // 0; # return undef if map is not matching,
|
||||||
my $inVal = $oRef->{'val'} // ''; # input value
|
my $inVal = $oRef->{'val'}; # input value
|
||||||
my $name = $hash->{NAME};
|
my $name = $hash->{NAME};
|
||||||
|
|
||||||
return $inVal if (!$map); # don't change anyting if map is empty
|
return $inVal if (!$map); # don't change anyting if map is empty
|
||||||
@ -346,19 +348,19 @@ sub MapConvert {
|
|||||||
$map =~ s/([^, ][^,\$]*):([^,][^,\$]*),? */$2:$1, /g; # reverse map
|
$map =~ s/([^, ][^,\$]*):([^,][^,\$]*),? */$2:$1, /g; # reverse map
|
||||||
}
|
}
|
||||||
# spaces in words allowed, separator is ',' or ':'
|
# spaces in words allowed, separator is ',' or ':'
|
||||||
my $val = decode ('UTF-8', $inVal); # convert nbsp from fhemweb
|
my $val = $inVal // '';
|
||||||
$val =~ s/\s| / /g; # back to normal spaces in case it came from FhemWeb with coded Blank
|
#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
|
my %mapHash = split (/, *|:/, $map); # reverse hash aus dem reverse string
|
||||||
|
|
||||||
if (defined($mapHash{$val})) { # Eintrag für den übergebenen Wert in der Map?
|
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
|
my $newVal = $mapHash{$val}; # entsprechender Raw-Wert für das Gerät
|
||||||
Log3 $name, 5, "$name: MapConvert called from " . FhemCaller() . " converted $val to $newVal with" .
|
Log3 $name, 5, "$name: MapConvert called from " . FhemCaller() . " converted $val ($inVal) to $newVal with" .
|
||||||
($reverse ? " reversed" : "") . " map $map";
|
($reverse ? " reversed" : "") . " map $map";
|
||||||
return $newVal;
|
return $newVal;
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
Log3 $name, 3, "$name: MapConvert called from " . FhemCaller() . " did not find $val in" .
|
Log3 $name, 3, "$name: MapConvert called from " . FhemCaller() . " did not find $val ($inVal) in" .
|
||||||
($reverse ? " reversed" : "") . " map $map";
|
($reverse ? " reversed" : "") . " map $map";
|
||||||
return if ($UndefIfNoMatch);
|
return if ($UndefIfNoMatch);
|
||||||
return $inVal;
|
return $inVal;
|
||||||
@ -409,12 +411,12 @@ sub CheckRange {
|
|||||||
sub FormatVal {
|
sub FormatVal {
|
||||||
my $hash = shift;
|
my $hash = shift;
|
||||||
my $oRef = shift; # optional hash ref for passing options and variables for use in expressions
|
my $oRef = shift; # optional hash ref for passing options and variables for use in expressions
|
||||||
my $val = $oRef->{'val'} // ''; # input value
|
my $val = $oRef->{'val'}; # input value
|
||||||
my $format = $oRef->{'format'} // ''; # format string
|
my $format = $oRef->{'format'} // ''; # format string
|
||||||
my $name = $hash->{NAME};
|
my $name = $hash->{NAME};
|
||||||
|
|
||||||
return $val if (!$format);
|
return $val if (!$format);
|
||||||
my $newVal = sprintf($format, $val);
|
my $newVal = sprintf($format, $val // '');
|
||||||
Log3 $name, 5, "$name: FormatVal for " . FhemCaller() . " formats $val with $format, result is $newVal";
|
Log3 $name, 5, "$name: FormatVal for " . FhemCaller() . " formats $val with $format, result is $newVal";
|
||||||
return $newVal;
|
return $newVal;
|
||||||
}
|
}
|
||||||
@ -492,27 +494,45 @@ sub ManageUserAttr {
|
|||||||
}
|
}
|
||||||
return $retVal;
|
return $retVal;
|
||||||
}
|
}
|
||||||
# go through all possible attrs and check if the passed attr matches one of the regex attrs
|
#Log3 $name, 5, "$name: ManageUserAttr for $aName called from " . FhemCaller(). ", userattr = " . ($attr{$name}{userattr} // '');
|
||||||
foreach my $listAttr (split " ", $modHash->{AttrList}) {
|
|
||||||
my ($listAttrName, $listAttrHint)
|
|
||||||
= $listAttr =~ m{ \A ([^:]+) (:?.*) }xms; # split 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
|
|
||||||
addToDevAttrList($name, $aName . $listAttrHint); # create userattr with hint to allow change in fhemweb
|
|
||||||
#Log3 $name, 5, "$name: ManageUserAttr added attr $aName to userattr list";
|
|
||||||
|
|
||||||
if ($listAttrHint) { # in case an earlier version added the attribute without the hint, remove old entry
|
MODATTRLOOP: # find the corresponding attr in the modules attrlist
|
||||||
my $uaList = $attr{$name}{userattr} // '';
|
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 %uaHash;
|
||||||
foreach my $userAttr (split(" ", $uaList)) {
|
my $found = 0;
|
||||||
if ($userAttr !~ m{\A $aName \z}xms) { # no match -> existing entry in userattr list is attribute without hint
|
|
||||||
$uaHash{$userAttr} = 1; # put $userAttr as key into the hash so it is kept in userattr
|
UALOOP:
|
||||||
|
foreach my $userAttr (split(" ", $uaList)) { # for every userAttr
|
||||||
|
my ($userAttrName, $userAttrHint)
|
||||||
|
= $userAttr =~ m{ \A ([^:]+) (:?.*) }xms; # split module 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";
|
||||||
|
next UALOOP if (!$userAttrHint && !$listAttrHint); # no hints -> no need for userattr to sepcify a regex attr (new)
|
||||||
|
if ($userAttrHint && !$listAttrHint) {
|
||||||
|
$uaHash{$userAttr} = 1; # keep $userAttr with hint if module attr has no hint
|
||||||
|
#Log3 $name, 5, "$name: ManageUserAttr keeps userattr $userAttr with different hint";
|
||||||
|
} else {
|
||||||
|
$uaHash{$aName . $listAttrHint} = 1; # replace userAttr with attr from module list
|
||||||
|
#Log3 $name, 5, "$name: ManageUserAttr uses $aName$listAttrHint with hint from module attr list";
|
||||||
}
|
}
|
||||||
else { # match -> in list without attr -> remove
|
$found = 1;
|
||||||
#Log3 $name, 5, "$name: ManageUserAttr removes attr $userAttr without hint $listAttrHint from userattr list";
|
} else {
|
||||||
|
$uaHash{$userAttr} = 1; # keep userattr with different names
|
||||||
|
#Log3 $name, 5, "$name: ManageUserAttr keeps other existing userattr $userAttr";
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
$attr{$name}{userattr} = join(" ", sort keys %uaHash);
|
if (!$found && $listAttrHint) { # add userAttr with attr from module list
|
||||||
|
$uaHash{$aName . $listAttrHint} = 1;
|
||||||
|
#Log3 $name, 5, "$name: ManageUserAttr adds $aName$listAttrHint";
|
||||||
}
|
}
|
||||||
|
$attr{$name}{userattr} = join(" ", sort keys %uaHash); # reconstruct userAttr list string
|
||||||
|
Log3 $name, 5, "$name: ManageUserAttr updated userattr list to $attr{$name}{userattr}";
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
return;
|
return;
|
||||||
@ -723,9 +743,9 @@ sub FmtTimeMs {
|
|||||||
my $time = shift // 0;
|
my $time = shift // 0;
|
||||||
my $seconds;
|
my $seconds;
|
||||||
my $mseconds;
|
my $mseconds;
|
||||||
if ($time =~ /([^\.]+)(\.(.*))?/) {
|
if ($time =~ /([^\.]+)(\.(.{0,3}))?/) {
|
||||||
$seconds = $1;
|
$seconds = $1;
|
||||||
$mseconds = $3;
|
$mseconds = $2 // 0;
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
$seconds = $time;
|
$seconds = $time;
|
||||||
@ -737,7 +757,7 @@ sub FmtTimeMs {
|
|||||||
|
|
||||||
my @t = localtime($seconds);
|
my @t = localtime($seconds);
|
||||||
my $tim = sprintf("%02d:%02d:%02d", $t[2],$t[1],$t[0]);
|
my $tim = sprintf("%02d:%02d:%02d", $t[2],$t[1],$t[0]);
|
||||||
$tim .= sprintf(".%03d", $mseconds);
|
$tim .= sprintf(".%03d", $mseconds * 1000);
|
||||||
return $tim;
|
return $tim;
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -753,4 +773,108 @@ sub ReadableArray {
|
|||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#####################################################
|
||||||
|
# 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 $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 $now, $key started at "
|
||||||
|
. $hash->{profiler}{start}{$key} . ", $lKey started at " . $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, over $overP over the pPeriod";
|
||||||
|
Log3 $name, 5, "$name: Profiling add " . ($lDiff - $overP) . " to sum for $key";
|
||||||
|
$hash->{profiler}{sums}{$lKey} += ($lDiff - $overP);
|
||||||
|
|
||||||
|
readingsBeginUpdate($hash);
|
||||||
|
foreach my $k (keys %{$hash->{profiler}{sums}}) {
|
||||||
|
my $val = sprintf('%.2f', $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 $overP";
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return if ($key eq $hash->{profiler}{lastKey}); # nothing new - take time when key or pPeriod changes
|
||||||
|
Log3 $name, 5, "$name: Profiling add $lDiff to sum for $lKey " .
|
||||||
|
"(now is $now, start for $lKey was $hash->{profiler}{start}{$lKey})";
|
||||||
|
$hash->{profiler}{sums}{$lKey} += $lDiff;
|
||||||
|
$hash->{profiler}{start}{$key} = $now;
|
||||||
|
$hash->{profiler}{lastKey} = $key;
|
||||||
|
}
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
1;
|
1;
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user