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
|
||||
FmtTimeMs
|
||||
ReadableArray
|
||||
Statistics Profiler
|
||||
);
|
||||
|
||||
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
|
||||
@ -181,12 +182,12 @@ sub StartQueueTimer {
|
||||
my $now = gettimeofday();
|
||||
my $delay = (defined($pDelay) ? $pDelay : AttrVal($name, 'queueDelay', 1));
|
||||
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() .
|
||||
' 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() .
|
||||
@ -210,10 +211,10 @@ sub StopQueueTimer {
|
||||
my $silent = $oRef->{'silent'} // 0;
|
||||
my $name = $ioHash->{NAME};
|
||||
if ($ioHash->{nextQueueRun}) {
|
||||
RemoveInternalTimer ("queue:$name");
|
||||
delete $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;
|
||||
}
|
||||
@ -317,9 +318,10 @@ sub EvalExpr {
|
||||
# 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 $1 if ($subroutine =~ /main::HTTPMOD_(.*)/);
|
||||
return $1 if ($subroutine =~ /main::(.*)/);
|
||||
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";
|
||||
}
|
||||
|
||||
@ -336,7 +338,7 @@ sub MapConvert {
|
||||
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 $inVal = $oRef->{'val'}; # input value
|
||||
my $name = $hash->{NAME};
|
||||
|
||||
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
|
||||
}
|
||||
# spaces in words allowed, separator is ',' or ':'
|
||||
my $val = decode ('UTF-8', $inVal); # convert nbsp from fhemweb
|
||||
$val =~ s/\s| / /g; # back to normal spaces in case it came from FhemWeb with coded Blank
|
||||
|
||||
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 to $newVal with" .
|
||||
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 in" .
|
||||
Log3 $name, 3, "$name: MapConvert called from " . FhemCaller() . " did not find $val ($inVal) in" .
|
||||
($reverse ? " reversed" : "") . " map $map";
|
||||
return if ($UndefIfNoMatch);
|
||||
return $inVal;
|
||||
@ -409,12 +411,12 @@ sub CheckRange {
|
||||
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 $val = $oRef->{'val'}; # input value
|
||||
my $format = $oRef->{'format'} // ''; # format string
|
||||
my $name = $hash->{NAME};
|
||||
|
||||
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";
|
||||
return $newVal;
|
||||
}
|
||||
@ -492,27 +494,45 @@ sub ManageUserAttr {
|
||||
}
|
||||
return $retVal;
|
||||
}
|
||||
# go through all possible attrs and check if the passed attr matches one of the regex attrs
|
||||
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";
|
||||
#Log3 $name, 5, "$name: ManageUserAttr for $aName called from " . FhemCaller(). ", userattr = " . ($attr{$name}{userattr} // '');
|
||||
|
||||
if ($listAttrHint) { # in case an earlier version added the attribute without the hint, remove old entry
|
||||
my $uaList = $attr{$name}{userattr} // '';
|
||||
my %uaHash;
|
||||
foreach my $userAttr (split(" ", $uaList)) {
|
||||
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
|
||||
}
|
||||
else { # match -> in list without attr -> remove
|
||||
#Log3 $name, 5, "$name: ManageUserAttr removes attr $userAttr without hint $listAttrHint from userattr list";
|
||||
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 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";
|
||||
}
|
||||
$found = 1;
|
||||
} 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;
|
||||
@ -723,9 +743,9 @@ sub FmtTimeMs {
|
||||
my $time = shift // 0;
|
||||
my $seconds;
|
||||
my $mseconds;
|
||||
if ($time =~ /([^\.]+)(\.(.*))?/) {
|
||||
if ($time =~ /([^\.]+)(\.(.{0,3}))?/) {
|
||||
$seconds = $1;
|
||||
$mseconds = $3;
|
||||
$mseconds = $2 // 0;
|
||||
}
|
||||
else {
|
||||
$seconds = $time;
|
||||
@ -737,7 +757,7 @@ sub FmtTimeMs {
|
||||
|
||||
my @t = localtime($seconds);
|
||||
my $tim = sprintf("%02d:%02d:%02d", $t[2],$t[1],$t[0]);
|
||||
$tim .= sprintf(".%03d", $mseconds);
|
||||
$tim .= sprintf(".%03d", $mseconds * 1000);
|
||||
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;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user