Public/fhem-mirror
1
0
Fork 0
mirror of https://github.com/fhem/fhem-mirror.git synced 2025-05-04 22:19:38 +00:00
Code Issues Packages Projects Releases Wiki Activity

98_HTTPMOD.pm: some new attributes, precompilation of regexes to avoid memory leak in some perl versions

Browse Source 
git-svn-id: https://svn.fhem.de/fhem/trunk/fhem@20519 2b470e98-0d58-463d-a4d8-8e2adae1ed80
This commit is contained in:
StefanStrobel 2019-11-16 14:46:01 +00:00
parent 03413d7608
commit b75c2cdc6f
1 changed files with 262 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

327
FHEM/98_HTTPMOD.pm
View File

@ -162,16 +162,20 @@
# 2019-01-13 check for featurelevl > 5.9 # 2019-01-13 check for featurelevl > 5.9
# 2019-02-13 remove Warning when checking for extractAllJSON == 2, new attribute extractAllJSONPrefix as regex filter # 2019-02-13 remove Warning when checking for extractAllJSON == 2, new attribute extractAllJSONPrefix as regex filter
# 2019-03-06 enhanced documentation # 2019-03-06 enhanced documentation
# 2019-10-16 add dumpBuffers attribute and memReading attribute for debugging
# 2019-10-26 new attributes bodyDecode and regexDecode
# 2019-10-29 store precompiled regexes in $hash, apply regexDecode to regexes already stored
# 2019-11-08 fixed a bug in handling userattr for wildcard attrs, added attr set[0-9]*Method
# 2019-11-11 modified precompilation of regexes to better support regex options
# #
# #
# #
# Todo: # Todo:
#
# extractAllReadings mit Filter / Prefix # extractAllReadings mit Filter / Prefix
# add examples to the documentation of attributes
# get after set um readings zu aktualisieren # get after set um readings zu aktualisieren
# definierbarer prefix oder Suffix für Readingsnamen wenn sie von unterschiedlichen gets über readingXY erzeugt werden # definierbarer prefix oder Suffix für Readingsnamen wenn sie von unterschiedlichen gets über readingXY erzeugt werden
#
# reading mit Status je get (error, no match, ...) oder reading zum nachverfolgen der schritte, fehler, auth etc. # reading mit Status je get (error, no match, ...) oder reading zum nachverfolgen der schritte, fehler, auth etc.
# #
# In _Attr bei Prüfungen auf get auch set berücksichtigen wo nötig, ebenso in der Attr Liste (oft fehlt set) # In _Attr bei Prüfungen auf get auch set berücksichtigen wo nötig, ebenso in der Attr Liste (oft fehlt set)
@ -183,7 +187,6 @@
# make extracting the sid after a get / update an attribute / option? # make extracting the sid after a get / update an attribute / option?
# multi page log extraction? # multi page log extraction?
# Profiling von Modbus übernehmen? # Profiling von Modbus übernehmen?
# extend httpmod to support simple tcp connections over devio instead of HttpUtils?
# #
# #
# Merkliste fürs nächste Fhem Release # Merkliste fürs nächste Fhem Release
@ -191,6 +194,7 @@
# - enableCookies # - enableCookies
# - handleRedirects # - handleRedirects
# - enableControlSet # - enableControlSet
# - bodyDecode auto
# #
# #
# #
@ -230,11 +234,11 @@ sub HTTPMOD_Get($@);
sub HTTPMOD_Attr(@); sub HTTPMOD_Attr(@);
sub HTTPMOD_GetUpdate($); sub HTTPMOD_GetUpdate($);
sub HTTPMOD_Read($$$); sub HTTPMOD_Read($$$);
sub HTTPMOD_AddToQueue($$$$$;$$$$); sub HTTPMOD_AddToQueue($$$$$;$$$$$);
sub HTTPMOD_JsonFlatter($$;$); sub HTTPMOD_JsonFlatter($$;$);
sub HTTPMOD_ExtractReading($$$$$); sub HTTPMOD_ExtractReading($$$$$);
my $HTTPMOD_Version = '3.5.9 - 13.2.2019'; my $HTTPMOD_Version = '3.5.16 - 11.11.2019';
# #
# FHEM module intitialisation # FHEM module intitialisation
@ -269,7 +273,7 @@ sub HTTPMOD_Initialize($)
"(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacement " . "(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacement " .
"(reading|get|set)[0-9]+Regex " . "(reading|get|set)[0-9]+Regex " .
"(reading|get|set)[0-9]+RegOpt " . # see http://perldoc.perl.org/perlre.html#Modifiers "(reading|get|set)[0-9]*RegOpt " . # see http://perldoc.perl.org/perlre.html#Modifiers
"(reading|get|set)[0-9]+XPath " . "(reading|get|set)[0-9]+XPath " .
"(reading|get|set)[0-9]+XPath-Strict " . "(reading|get|set)[0-9]+XPath-Strict " .
"(reading|get|set)[0-9]+JSON " . "(reading|get|set)[0-9]+JSON " .
@ -329,6 +333,7 @@ sub HTTPMOD_Initialize($)
"set[0-9]*NoArg:0,1 " . # don't expect a value - for set on / off and similar. (default for get) "set[0-9]*NoArg:0,1 " . # don't expect a value - for set on / off and similar. (default for get)
"[gs]et[0-9]*TextArg:0,1 " . # just pass on a raw text value without validation / further conversion "[gs]et[0-9]*TextArg:0,1 " . # just pass on a raw text value without validation / further conversion
"set[0-9]*ParseResponse:0,1 " . # parse response to set as if it was a get "set[0-9]*ParseResponse:0,1 " . # parse response to set as if it was a get
"set[0-9]*Method:GET,POST,PUT " . # select HTTP method for the set
"reAuthRegex " . "reAuthRegex " .
"reAuthAlways:0,1 " . "reAuthAlways:0,1 " .
@ -373,7 +378,13 @@ sub HTTPMOD_Initialize($)
"enableXPath-Strict:0,1 " . # old "enableXPath-Strict:0,1 " . # old
"enforceGoodReadingNames " . "enforceGoodReadingNames " .
"dontRequeueAfterAuth " . "dontRequeueAfterAuth " .
"dumpBuffers " . # debug -> write buffers to files
"memReading " . # debuf -> create a reading for the virtual Memory of the Fhem process together with BufCounter if it is used
"model " . # for attr templates "model " . # for attr templates
"regexDecode " .
"regexCompile " .
"bodyDecode " .
"regexCompile " .
$readingFnAttributes; $readingFnAttributes;
} }
@ -403,7 +414,7 @@ sub HTTPMOD_SetTimer($;$)
$hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger); $hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger);
RemoveInternalTimer("update:$name"); RemoveInternalTimer("update:$name");
InternalTimer($nextTrigger, "HTTPMOD_GetUpdate", "update:$name", 0); InternalTimer($nextTrigger, "HTTPMOD_GetUpdate", "update:$name", 0);
Log3 $name, 4, "$name: update timer modified: will call GetUpdate in " . Log3 $name, 5, "$name: update timer modified: will call GetUpdate in " .
sprintf ("%.1f", $nextTrigger - $now) . " seconds at $hash->{TRIGGERTIME_FMT}"; sprintf ("%.1f", $nextTrigger - $now) . " seconds at $hash->{TRIGGERTIME_FMT}";
} else { } else {
$hash->{TRIGGERTIME} = 0; $hash->{TRIGGERTIME} = 0;
@ -526,26 +537,26 @@ sub HTTPMOD_ManageUserAttr($$)
my $modHash = $modules{$hash->{TYPE}}; my $modHash = $modules{$hash->{TYPE}};
# handle wild card attributes -> Add to userattr to allow modification in fhemweb # handle wild card attributes -> Add to userattr to allow modification in fhemweb
#Log3 $name, 3, "$name: attribute $aName checking ";
if (" $modHash->{AttrList} " !~ m/ ${aName}[ :;]/) { if (" $modHash->{AttrList} " !~ m/ ${aName}[ :;]/) {
# nicht direkt in der Liste -> evt. wildcard attr in AttrList # nicht direkt in der Liste -> evt. wildcard attr in AttrList
foreach my $la (split " ", $modHash->{AttrList}) { foreach my $la (split " ", $modHash->{AttrList}) {
$la =~ /([^:;]+)(:?.*)/; $la =~ /^([^:;]+)(:?.*)$/;
my $vgl = $1; # attribute name in list - probably a regex my $vgl = $1; # attribute name in list - probably a regex
my $opt = $2; # attribute hint in list my $opt = $2; # attribute hint in list
if ($aName =~ $vgl) { # yes - the name in the list now matches as regex if ($aName =~ /^$vgl$/) { # yes - the name in the list now matches as regex
# $aName ist eine Ausprägung eines wildcard attrs # $aName ist eine Ausprägung eines wildcard attrs
addToDevAttrList($name, "$aName" . $opt); # create userattr with hint to allow change in fhemweb addToDevAttrList($name, "$aName" . $opt); # create userattr with hint to allow change in fhemweb
#Log3 $name, 5, "$name: ManageUserAttr added attr $aName with $opt to userattr list";
if ($opt) { if ($opt) {
# remove old entries without hint # remove old entries without hint
my $ualist = $attr{$name}{userattr}; my $ualist = $attr{$name}{userattr};
$ualist = "" if(!$ualist); $ualist = "" if(!$ualist);
my %uahash; my %uahash;
foreach my $a (split(" ", $ualist)) { foreach my $a (split(" ", $ualist)) {
if ($a !~ /^${aName}$/) { # entry in userattr list is attribute without hint if ($a !~ /^${aName}$/) { # no match -> existing entry in userattr list is attribute without hint
$uahash{$a} = 1; $uahash{$a} = 1; # put $a as key into the hash so it is kept in userattr later
} else { } else { # match -> in list without attr -> remove
Log3 $name, 3, "$name: added hint $opt to attr $a in userattr list"; #Log3 $name, 5, "$name: ManageUserAttr removes attr $a without hint $opt from userattr list";
} }
} }
$attr{$name}{userattr} = join(" ", sort keys %uahash); $attr{$name}{userattr} = join(" ", sort keys %uahash);
@ -562,13 +573,71 @@ sub HTTPMOD_ManageUserAttr($$)
} }
#
# precompile regex attr value
###################################
sub HTTPMOD_PrecompileRegexAttr($$$)
{
my ($hash, $aName, $aVal) = @_;
my $name = $hash->{NAME};
my $regopt;
my $regDecode = AttrVal($name, 'regexDecode', "");
if ($regDecode && $regDecode !~ /^[Nn]one$/) {
$aVal = decode($regDecode, $aVal);
Log3 $name, 5, "$name: PrecompileRegexAttr is decoding regex $aName as $regDecode";
}
if ($aName =~ /^(reading|get|set)([0-9]+).*Regex$/) {
my $context = $1;
my $num = $2;
$regopt = HTTPMOD_GetFAttr($name, $context, $num, "RegOpt");
$regopt =~ s/[gceor]//g; # remove gceor options - they will be added when using the regex
# see https://www.perlmonks.org/?node_id=368332
}
$regopt = '' if (!defined($regopt));
my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT');
$SIG{__WARN__} = sub { Log3 $name, 3, "$name: PrecompileRegexAttr for $aName $aVal created warning: @_"; };
eval "\$hash->{CompiledRegexes}{\$aName} = qr/$aVal/$regopt";
$SIG{__WARN__} = $oldSig;
if (!$@) {
if ($aVal =~ /^xpath:(.*)/ || $aVal =~ /^xpath-strict:(.*)/) {
Log3 $name, 3, "$name: PrecompileRegexAttr cannot store precompiled regex because outdated xpath syntax is used in attr $aName $aVal. Please upgrade attributes";
delete $hash->{CompiledRegexes}{$aName};
} else {
Log3 $name, 5, "$name: PrecompileRegexAttr precompiled $aName /$aVal/$regopt to $hash->{CompiledRegexes}{$aName}";
}
}
}
#
# decode and precompile existing regex attr values
# not needed anymore since compilation is done at first use
###############################################################
sub HTTPMOD_DecodeRegexAttrs($$)
{
my ($hash, $encoding) = @_;
my $name = $hash->{NAME};
foreach my $aName (keys %{$attr{$name}}) {
if ($aName =~ /(.+)Regex$/) {
HTTPMOD_PrecompileRegexAttr($hash, $aName, $attr{$name}{$aName}); # decode and recompile each regex attr
}
}
}
# #
# Attr command # Attr command
######################################################################### #########################################################################
sub HTTPMOD_Attr(@) sub HTTPMOD_Attr(@)
{ {
my ($cmd,$name,$aName,$aVal) = @_; my ($cmd,$name,$aName,$aVal) = @_;
my $hash = $defs{$name}; my $hash = $defs{$name};
my ($sid, $old); # might be needed inside a URLExpr my ($sid, $old); # might be needed inside a URLExpr
# $cmd can be "del" or "set" # $cmd can be "del" or "set"
@ -580,15 +649,17 @@ sub HTTPMOD_Attr(@)
# if validation fails, return something so CommandAttr in fhem.pl doesn't assign a value to $attr # if validation fails, return something so CommandAttr in fhem.pl doesn't assign a value to $attr
if ($cmd eq "set") { if ($cmd eq "set") {
if ($aName =~ /^regexDecode$/) {
delete $hash->{CompiledRegexes}; # recompile everything with the right decoding
Log3 $name, 4, "$name: Attr got DecodeRegexAttr -> delete all potentially precompiled regexs";
}
if ($aName =~ /Regex/) { # catch all Regex like attributes if ($aName =~ /Regex/) { # catch all Regex like attributes
my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); #HTTPMOD_PrecompileRegexAttr($hash, $aName, $aVal);
$SIG{__WARN__} = sub { Log3 $name, 3, "$name: set attr $aName $aVal created warning: @_"; }; # precompile at first use and consider regopt with it.
eval {qr/$aVal/}; delete $hash->{CompiledRegexes}{$aName};
$SIG{__WARN__} = $oldSig; Log3 $name, 4, "$name: Attr got regex attr -> delete potentially precompiled regex for $aName";
if ($@) {
Log3 $name, 3, "$name: Attr with invalid regex in attr $name $aName $aVal: $@";
return "Invalid Regex $aVal";
}
if ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex$/) { if ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex$/) {
$hash->{ReplacementEnabled} = 1; $hash->{ReplacementEnabled} = 1;
} }
@ -607,7 +678,7 @@ sub HTTPMOD_Attr(@)
Log3 $name, 3, "$name: illegal RegOpt in attr $name $aName $aVal"; Log3 $name, 3, "$name: illegal RegOpt in attr $name $aName $aVal";
return "$name: illegal RegOpt in attr $name $aName $aVal"; return "$name: illegal RegOpt in attr $name $aName $aVal";
} }
} elsif ($aName =~ /Expr/) { # validate all Expressions } elsif ($aName =~ /Expr/) {
my $val = 0; my $old = 0; my $val = 0; my $old = 0;
my $timeDiff = 0; # to be available in Exprs my $timeDiff = 0; # to be available in Exprs
my @matchlist = (); my @matchlist = ();
@ -730,6 +801,7 @@ sub HTTPMOD_Attr(@)
} elsif ($aName =~ /^(reading|get)([0-9]+)(-[0-9]+)?Name$/) { } elsif ($aName =~ /^(reading|get)([0-9]+)(-[0-9]+)?Name$/) {
$hash->{".updateRequestHash"} = 1; $hash->{".updateRequestHash"} = 1;
} }
my $err = HTTPMOD_ManageUserAttr($hash, $aName); my $err = HTTPMOD_ManageUserAttr($hash, $aName);
@ -788,7 +860,10 @@ sub HTTPMOD_Attr(@)
} elsif ($aName eq 'alignTime') { } elsif ($aName eq 'alignTime') {
delete $hash->{TimeAlign}; delete $hash->{TimeAlign};
delete $hash->{TimeAlignFmt}; delete $hash->{TimeAlignFmt};
} }
} }
if ($aName =~ /^[gs]et/ || $aName eq "enableControlSet") { if ($aName =~ /^[gs]et/ || $aName eq "enableControlSet") {
$hash->{".updateHintList"} = 1; $hash->{".updateHintList"} = 1;
@ -1049,7 +1124,8 @@ sub HTTPMOD_Replace($$$)
next if ($rr !~ /^replacement([0-9]*)Regex$/); next if ($rr !~ /^replacement([0-9]*)Regex$/);
my $rNum = $1; my $rNum = $1;
#Log3 $name, 5, "$name: Replace: rr=$rr, rNum $rNum, look for ${type}Replacement${rNum}Value"; #Log3 $name, 5, "$name: Replace: rr=$rr, rNum $rNum, look for ${type}Replacement${rNum}Value";
my $regex = AttrVal($name, "replacement${rNum}Regex", ""); my $regex = HTTPMOD_GetRegex($name, "replacement", $rNum, "Regex", "");
#my $regex = AttrVal($name, "replacement${rNum}Regex", "");
my $mode = AttrVal($name, "replacement${rNum}Mode", "text"); my $mode = AttrVal($name, "replacement${rNum}Mode", "text");
next if (!$regex); next if (!$regex);
@ -1110,7 +1186,7 @@ sub HTTPMOD_Replace($$$)
$match = 1; $match = 1;
} }
} }
Log3 $name, 4, "$name: Replace: match for type $type, regex $regex, mode $mode, " . Log3 $name, 5, "$name: Replace: match for type $type, regex $regex, mode $mode, " .
($value ? "value $value," : "empty value,") . " input: $input, result is $string" if ($match); ($value ? "value $value," : "empty value,") . " input: $input, result is $string" if ($match);
} }
return $string; return $string;
@ -1531,7 +1607,7 @@ sub HTTPMOD_Set($@)
my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "set", $setNum); my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "set", $setNum);
if ($url) { if ($url) {
HTTPMOD_Auth $hash if (AttrVal($name, "reAuthAlways", 0)); HTTPMOD_Auth $hash if (AttrVal($name, "reAuthAlways", 0));
HTTPMOD_AddToQueue($hash, $url, $header, $data, "set$setNum", $rawVal); HTTPMOD_AddToQueue($hash, $url, $header, $data, "set$setNum", $rawVal, 0, 0, 0, AttrVal($name, "set${setNum}Method", ''));
} else { } else {
Log3 $name, 3, "$name: no URL for set $setNum"; Log3 $name, 3, "$name: no URL for set $setNum";
} }
@ -1602,7 +1678,7 @@ sub HTTPMOD_GetUpdate($)
my ($url, $header, $data, $count); my ($url, $header, $data, $count);
my $now = gettimeofday(); my $now = gettimeofday();
Log3 $name, 4, "$name: GetUpdate called ($calltype)"; Log3 $name, 5, "$name: GetUpdate called ($calltype)";
if ($calltype eq "update") { if ($calltype eq "update") {
HTTPMOD_SetTimer($hash); HTTPMOD_SetTimer($hash);
@ -1786,6 +1862,49 @@ sub HTTPMOD_FlattenJSON($$)
} }
# get a regex from attr and compile if not done
################################################
sub HTTPMOD_GetRegex($$$$$)
{
my ($name, $context, $num, $type, $default) = @_;
my $hash = $defs{$name};
my $val;
my $regDecode = AttrVal($name, 'regexDecode', "");
my $regCompile = AttrVal($name, 'regexCompile', 1);
# first look for attribute with the full num in it
if ($num && defined ($attr{$name}{$context . $num . $type})) { # specific regex attr exists
return $attr{$name}{$context . $num . $type} if (!$regCompile);
if ($hash->{CompiledRegexes}{$context . $num . $type}) { # compiled specific regex esists
$val = $hash->{CompiledRegexes}{$context . $num . $type};
Log3 $name, 5, "$name: GetRegex found precompiled $type for $context$num";
} else { # not compiled (yet)
$val = $attr{$name}{$context . $num . $type};
HTTPMOD_PrecompileRegexAttr($hash, $context . $num . $type, $val);
$val = $hash->{CompiledRegexes}{$context . $num . $type};
}
# if not found then look for generic attribute without num
} elsif (defined ($attr{$name}{$context . $type})) { # generic regex attr exists
return $attr{$name}{$context . $type} if (!$regCompile);
if ($hash->{CompiledRegexes}{$context . $type}) {
$val = $hash->{CompiledRegexes}{$context . $type};
Log3 $name, 5, "$name: GetRegex found precompiled $type for $context";
} else {
$val = $attr{$name}{$context . $type}; # not compiled (yet)
HTTPMOD_PrecompileRegexAttr($hash, $context . $type, $val);
$val = $hash->{CompiledRegexes}{$context . $type};
}
} else {
$val = $default;
return if (!$val) # default is not compiled - should only be "" or similar
}
return $val;
}
# format a reading value # format a reading value
################################### ###################################
sub HTTPMOD_FormatReading($$$$$) sub HTTPMOD_FormatReading($$$$$)
@ -1873,11 +1992,11 @@ sub HTTPMOD_ExtractReading($$$$$)
} }
# new syntax overrides reading and regex # new syntax overrides reading and regex
$reading = HTTPMOD_GetFAttr($name, $context, $num, "Name", $reading); $reading = HTTPMOD_GetFAttr($name, $context, $num, "Name", $reading);
$regex = HTTPMOD_GetFAttr($name, $context, $num, "Regex", $regex); $regex = HTTPMOD_GetRegex($name, $context, $num, "Regex", $regex);
my %namedRegexGroups; my %namedRegexGroups;
if ($regex) { if ($regex) {
# old syntax for xpath and xpath-strict as prefix in regex - one result joined # old syntax for xpath and xpath-strict as prefix in regex - one result joined
if (AttrVal($name, "enableXPath", undef) && $regex =~ /^xpath:(.*)/) { if (AttrVal($name, "enableXPath", undef) && $regex =~ /^xpath:(.*)/) {
$xpath = $1; $xpath = $1;
@ -1898,9 +2017,10 @@ sub HTTPMOD_ExtractReading($$$$$)
} }
} }
@matchlist = (join ",", @matchlist); # old syntax returns only one value @matchlist = (join ",", @matchlist); # old syntax returns only one value
} else {
# normal regex } else { # normal regex
if ($regopt) { if ($regopt) {
$regopt =~ s/[^gceor]//g; # remove anything but gceor options - rest is already compiled in
Log3 $name, 5, "$name: ExtractReading $reading with regex /$regex/$regopt ..."; Log3 $name, 5, "$name: ExtractReading $reading with regex /$regex/$regopt ...";
eval '@matchlist = ($buffer =~ /' . "$regex/$regopt" . ')'; eval '@matchlist = ($buffer =~ /' . "$regex/$regopt" . ')';
Log3 $name, 3, "$name: error in regex matching with regex option: $@" if ($@); Log3 $name, 3, "$name: error in regex matching with regex option: $@" if ($@);
@ -1910,7 +2030,7 @@ sub HTTPMOD_ExtractReading($$$$$)
@matchlist = ($buffer =~ /$regex/); @matchlist = ($buffer =~ /$regex/);
%namedRegexGroups = %+ if (%+); %namedRegexGroups = %+ if (%+);
} }
Log3 $name, 5, "$name: " . @matchlist . " capture group(s), " . Log3 $name, 5, "$name: " . @matchlist . " matches, " .
(%namedRegexGroups ? "named capture groups, " : "") . (%namedRegexGroups ? "named capture groups, " : "") .
"matchlist = " . join ",", @matchlist if (@matchlist); "matchlist = " . join ",", @matchlist if (@matchlist);
} }
@ -1989,7 +2109,7 @@ sub HTTPMOD_ExtractReading($$$$$)
my $eNum = $num . ($group ? "-".$group : ""); my $eNum = $num . ($group ? "-".$group : "");
$val = HTTPMOD_FormatReading($hash, $context, $eNum, $val, $subReading); $val = HTTPMOD_FormatReading($hash, $context, $eNum, $val, $subReading);
Log3 $name, 4, "$name: ExtractReading for $context$num sets reading for named capture group $subReading to $val"; Log3 $name, 5, "$name: ExtractReading for $context$num sets reading for named capture group $subReading to $val";
readingsBulkUpdate( $hash, $subReading, $val ); readingsBulkUpdate( $hash, $subReading, $val );
# point from reading name back to the parsing definition as reading01 or get02 ... # point from reading name back to the parsing definition as reading01 or get02 ...
$hash->{defptr}{readingBase}{$subReading} = $context; # used to find maxAge attr $hash->{defptr}{readingBase}{$subReading} = $context; # used to find maxAge attr
@ -2024,7 +2144,7 @@ sub HTTPMOD_ExtractReading($$$$$)
push @subrlist, $subReading; push @subrlist, $subReading;
$val = HTTPMOD_FormatReading($hash, $context, $eNum, $val, $subReading); $val = HTTPMOD_FormatReading($hash, $context, $eNum, $val, $subReading);
Log3 $name, 4, "$name: ExtractReading for $context$num-$group sets $subReading to $val"; Log3 $name, 5, "$name: ExtractReading for $context$num-$group sets $subReading to $val";
readingsBulkUpdate( $hash, $subReading, $val ); readingsBulkUpdate( $hash, $subReading, $val );
# point from reading name back to the parsing definition as reading01 or get02 ... # point from reading name back to the parsing definition as reading01 or get02 ...
$hash->{defptr}{readingBase}{$subReading} = $context; # used to find maxAge attr $hash->{defptr}{readingBase}{$subReading} = $context; # used to find maxAge attr
@ -2052,7 +2172,7 @@ sub HTTPMOD_PullToFile($$$$)
my $name = $hash->{NAME}; my $name = $hash->{NAME};
my $reading = HTTPMOD_GetFAttr($name, "get", $num, "Name"); my $reading = HTTPMOD_GetFAttr($name, "get", $num, "Name");
my $regex = HTTPMOD_GetFAttr($name, "get", $num, "Regex"); my $regex = HTTPMOD_GetFAttr($name, "get", $num, "Regex"); # todo: change to GetRegex if this feature ever gets finished (or remove)
my $iterate = HTTPMOD_GetFAttr($name, "get", $num, "PullIterate"); my $iterate = HTTPMOD_GetFAttr($name, "get", $num, "PullIterate");
my $recombine = HTTPMOD_GetFAttr($name, "get", $num, "RecombineExpr"); my $recombine = HTTPMOD_GetFAttr($name, "get", $num, "RecombineExpr");
$recombine = '$1' if not ($recombine); $recombine = '$1' if not ($recombine);
@ -2375,13 +2495,17 @@ sub HTTPMOD_ExtractSid($$$$)
my $name = $hash->{NAME}; my $name = $hash->{NAME};
Log3 $name, 5, "$name: ExtractSid called, context $context, num $num"; Log3 $name, 5, "$name: ExtractSid called, context $context, num $num";
my $regex = AttrVal($name, "idRegex", ""); #my $regex = AttrVal($name, "idRegex", "");
my $regex = HTTPMOD_GetRegex($name, "", "", "idRegex", "");
my $json = AttrVal($name, "idJSON", ""); my $json = AttrVal($name, "idJSON", "");
my $xpath = AttrVal($name, "idXPath", ""); my $xpath = AttrVal($name, "idXPath", "");
my $xpathst = AttrVal($name, "idXPath-Strict", ""); my $xpathst = AttrVal($name, "idXPath-Strict", "");
$regex = HTTPMOD_GetFAttr($name, $context, $num, "IDRegex", $regex); #$regex = HTTPMOD_GetFAttr($name, $context, $num, "IDRegex", $regex);
$regex = HTTPMOD_GetFAttr($name, $context, $num, "IdRegex", $regex); #$regex = HTTPMOD_GetFAttr($name, $context, $num, "IdRegex", $regex);
$regex = HTTPMOD_GetRegex($name, $context, $num, "IdRegex", $regex);
$regex = HTTPMOD_GetRegex($name, $context, $num, "IDRegex", $regex);
$json = HTTPMOD_GetFAttr($name, $context, $num, "IdJSON", $json); $json = HTTPMOD_GetFAttr($name, $context, $num, "IdJSON", $json);
$xpath = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath", $xpath); $xpath = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath", $xpath);
$xpathst = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath-Strict", $xpathst); $xpathst = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath-Strict", $xpathst);
@ -2442,13 +2566,16 @@ sub HTTPMOD_CheckAuth($$$$$)
my $name = $hash->{NAME}; my $name = $hash->{NAME};
my $doAuth; my $doAuth;
my $regex = AttrVal($name, "reAuthRegex", ""); #my $regex = AttrVal($name, "reAuthRegex", "");
my $regex = HTTPMOD_GetRegex($name, "", "", "reAuthRegex", "");
my $json = AttrVal($name, "reAuthJSON", ""); my $json = AttrVal($name, "reAuthJSON", "");
my $xpath = AttrVal($name, "reAuthXPath", ""); my $xpath = AttrVal($name, "reAuthXPath", "");
my $xpathst = AttrVal($name, "reAuthXPath-Strict", ""); my $xpathst = AttrVal($name, "reAuthXPath-Strict", "");
if ($context =~ /([gs])et/) { if ($context =~ /([gs])et/) {
$regex = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthRegex", $regex); #$regex = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthRegex", $regex);
$regex = HTTPMOD_GetRegex($name, $context, $num, "ReAuthRegex", $regex);
$json = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthJSON", $json); $json = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthJSON", $json);
$xpath = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthXPath", $xpath); $xpath = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthXPath", $xpath);
$xpathst = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthXPath-Strict", $xpathst); $xpathst = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthXPath-Strict", $xpathst);
@ -2507,7 +2634,7 @@ sub HTTPMOD_CheckAuth($$$$$)
Log3 $name, 4, "$name: Authentication still required but no retries left - did last authentication fail?"; Log3 $name, 4, "$name: Authentication still required but no retries left - did last authentication fail?";
} }
} else { } else {
Log3 $name, 4, "$name: CheckAuth decided no authentication required"; Log3 $name, 5, "$name: CheckAuth decided no authentication required";
} }
return 0; return 0;
} }
@ -2568,7 +2695,8 @@ sub HTTPMOD_CheckRedirects($$)
return; return;
} }
Log3 $name, 4, "$name: $url: Redirect ($hash->{HTTPMOD_Redirects}) to $rurl"; Log3 $name, 4, "$name: $url: Redirect ($hash->{HTTPMOD_Redirects}) to $rurl";
# add new url with prio to queue, old header, no data todo: redirect with post possible / supported?? # add new url with prio to queue, old header, no data
# todo: redirect with post possible / supported??
HTTPMOD_AddToQueue($hash, $rurl, $request->{header}, "", $type, undef, $request->{retryCount}, 0, 1); HTTPMOD_AddToQueue($hash, $rurl, $request->{header}, "", $type, undef, $request->{retryCount}, 0, 1);
HTTPMOD_HandleSendQueue("direct:".$name); # AddToQueue with prio did not call this. HTTPMOD_HandleSendQueue("direct:".$name); # AddToQueue with prio did not call this.
return 1; return 1;
@ -2603,7 +2731,7 @@ sub HTTPMOD_Read($$$)
if (!$name || $hash->{TYPE} ne "HTTPMOD") { if (!$name || $hash->{TYPE} ne "HTTPMOD") {
$name = "HTTPMOD"; $name = "HTTPMOD";
Log3 $name, 3, "HTTPMOD _Read callback was called with illegal hash - this should never happen - problem in HttpUtils?"; Log3 $name, 3, "$name: HTTPMOD _Read callback was called with illegal hash - this should never happen - problem in HttpUtils?";
return undef; return undef;
} }
@ -2611,16 +2739,62 @@ sub HTTPMOD_Read($$$)
Log3 $name, 3, "$name: Read callback: Error: $err" if ($err); Log3 $name, 3, "$name: Read callback: Error: $err" if ($err);
Log3 $name, 4, "$name: Read callback: request type was $type" . Log3 $name, 4, "$name: Read callback: request type was $type" .
" retry $request->{retryCount}" . " retry $request->{retryCount}" .
#($header ? ",\r\nHeader: $header" : ", no headers") . ($header ? ",\r\nheader: $header" : ", no headers") .
($body ? ",\r\nBody: $body" : ", body empty"); ($body ? ", body length " . length($body) : ", no body");
Log3 $name, 5, "$name: Read callback: " .
($body ? "body\r\n$body" : "body empty");
$body = "" if (!$body); $body = "" if (!$body);
my $ppr = AttrVal($name, "preProcessRegex", "");
if (AttrVal($name, "memReading", 0)) {
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}" : "");
}
if (AttrVal($name, "dumpBuffers", 0)) {
my $fh;
$hash->{BufCounter} = 0 if (!$hash->{BufCounter});
$hash->{BufCounter} ++;
my $path = AttrVal($name, "dumpBuffers", 0);
open($fh, '>', "$path/buffer$hash->{BufCounter}.txt");
if ($header) {
print $fh $header;
print $fh "\r\n\r\n";
}
print $fh $body;
close $fh;
}
my $fDefault = ($featurelevel > 5.9 ? 'auto' : '');
my $bodyDecode = AttrVal($name, 'bodyDecode', $fDefault);
if ($bodyDecode eq 'auto' or $bodyDecode eq 'Auto') {
if ($header =~/Content-Type:.*charset=([\w\-\.]+)/i) {
$bodyDecode = $1;
Log3 $name, 4, "$name: Read found charset header and set decoding to $bodyDecode (bodyDecode was set to auto)";
} else {
$bodyDecode = "";
Log3 $name, 4, "$name: Read found no charset header (bodyDecode was set to auto)";
}
}
if ($bodyDecode) {
$buffer = decode($bodyDecode, $buffer);
Log3 $name, 4, "$name: Read is decoding the buffer as $bodyDecode ";
}
#my $ppr = AttrVal($name, "preProcessRegex", "");
my $ppr = HTTPMOD_GetRegex($name, "", "", "preProcessRegex", "");
if ($ppr) { if ($ppr) {
my $pprexp = '$body=~' . $ppr; my $pprexp = '$body=~' . $ppr;
my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT');
$SIG{__WARN__} = sub { Log3 $name, 3, "$name: read applying preProcessRegex created warning: @_"; }; $SIG{__WARN__} = sub { Log3 $name, 3, "$name: Read applying preProcessRegex created warning: @_"; };
eval $pprexp; eval $pprexp;
$SIG{__WARN__} = $oldSig; $SIG{__WARN__} = $oldSig;
@ -2630,7 +2804,7 @@ sub HTTPMOD_Read($$$)
$buffer = ($header ? $header . "\r\n\r\n" . $body : $body); # for matching sid / reauth $buffer = ($header ? $header . "\r\n\r\n" . $body : $body); # for matching sid / reauth
$buffer = $buffer . "\r\n\r\n" . $err if ($err); # for matching reauth $buffer = $buffer . "\r\n\r\n" . $err if ($err); # for matching reauth
#delete $hash->{buf} if (AttrVal($name, "removeBuf", 0)); #delete $hash->{buf} if (AttrVal($name, "removeBuf", 0));
if (AttrVal($name, "showBody", 0)) { if (AttrVal($name, "showBody", 0)) {
$hash->{httpbody} = $body; $hash->{httpbody} = $body;
@ -2767,10 +2941,11 @@ sub HTTPMOD_Read($$$)
} }
if (!@matched) { if (!@matched) {
Log3 $name, 3, "$name: Read response to $type didn't match any Reading"; Log3 $name, 4, "$name: Read response to $type didn't match any Reading";
} else { } else {
Log3 $name, 4, "$name: Read response to $type matched Reading(s) " . join ' ', @matched; Log3 $name, 4, "$name: Read response matched " . scalar(@matched) .", unmatch " . scalar(@unmatched) . " Reading(s)";
Log3 $name, 4, "$name: Read response to $type did not match " . join ' ', @unmatched if (@unmatched); Log3 $name, 5, "$name: Read response to $type matched " . join ' ', @matched;
Log3 $name, 5, "$name: Read response to $type did not match " . join ' ', @unmatched if (@unmatched);
} }
HTTPMOD_TryCall($hash, $buffer, 'parseFunction1', $type); HTTPMOD_TryCall($hash, $buffer, 'parseFunction1', $type);
@ -2849,6 +3024,10 @@ sub HTTPMOD_HandleSendQueue($)
$hash->{value} = $hash->{REQUEST}{value}; $hash->{value} = $hash->{REQUEST}{value};
$hash->{timeout} = AttrVal($name, "timeout", 2); $hash->{timeout} = AttrVal($name, "timeout", 2);
$hash->{httpversion} = AttrVal($name, "httpVersion", "1.0"); $hash->{httpversion} = AttrVal($name, "httpVersion", "1.0");
if($hash->{REQUEST}{method}) { # check if optional parameter for HTTP Method is set
$hash->{method} = $hash->{REQUEST}{method};
Log3 $name, 5, "$name: HandleSendQueue - call with HTTP METHOD: $hash->{method} ";
}
my $fDefault = ($featurelevel > 5.9 ? 1 : 0); my $fDefault = ($featurelevel > 5.9 ? 1 : 0);
if (AttrVal($name, "handleRedirects", $fDefault)) { if (AttrVal($name, "handleRedirects", $fDefault)) {
$hash->{ignoreredirects} = 1; # HttpUtils should not follow redirects if we do it in HTTPMOD $hash->{ignoreredirects} = 1; # HttpUtils should not follow redirects if we do it in HTTPMOD
@ -2894,7 +3073,7 @@ sub HTTPMOD_HandleSendQueue($)
if (AttrVal($name, "enableCookies", $fDefault)) { if (AttrVal($name, "enableCookies", $fDefault)) {
my $uriPath = ""; my $uriPath = "";
if($hash->{url} =~ / if($hash->{url} =~ /
^(http|https):\/\/ # $1: proto ^(http|https):\/\/ # $1: proto
(([^:\/]+):([^:\/]+)@)? # $2: auth, $3:user, $4:password (([^:\/]+):([^:\/]+)@)? # $2: auth, $3:user, $4:password
([^:\/]+|\[[0-9a-f:]+\]) # $5: host or IPv6 address ([^:\/]+|\[[0-9a-f:]+\]) # $5: host or IPv6 address
(:\d+)? # $6: port (:\d+)? # $6: port
@ -2934,11 +3113,10 @@ sub HTTPMOD_HandleSendQueue($)
} }
} }
Log3 $name, 4, "$name: HandleSendQueue sends request type $hash->{REQUEST}{type} to " . Log3 $name, 4, "$name: HandleSendQueue sends $hash->{REQUEST}{type} with timeout $hash->{timeout} to " .
"URL $hash->{url}, " . "$hash->{url}, " .
($hash->{data} ? "\r\ndata: $hash->{data}, " : "No Data, ") . ($hash->{data} ? "\r\ndata: $hash->{data}, " : "No Data, ") .
($hash->{header} ? "\r\nheader: $hash->{header}" : "No Header") . ($hash->{header} ? "\r\nheader: $hash->{header}" : "No Header");
"\r\ntimeout $hash->{timeout}";
shift(@{$queue}); # remove first element from queue shift(@{$queue}); # remove first element from queue
HttpUtils_NonblockingGet($hash); HttpUtils_NonblockingGet($hash);
@ -2955,8 +3133,8 @@ sub HTTPMOD_HandleSendQueue($)
##################################### #####################################
sub HTTPMOD_AddToQueue($$$$$;$$$$){ sub HTTPMOD_AddToQueue($$$$$;$$$$$){
my ($hash, $url, $header, $data, $type, $value, $count, $ignoreredirects, $prio) = @_; my ($hash, $url, $header, $data, $type, $value, $count, $ignoreredirects, $prio, $method) = @_;
my $name = $hash->{NAME}; my $name = $hash->{NAME};
$value = 0 if (!$value); $value = 0 if (!$value);
@ -2971,16 +3149,18 @@ sub HTTPMOD_AddToQueue($$$$$;$$$$){
$request{value} = $value; $request{value} = $value;
$request{retryCount} = $count; $request{retryCount} = $count;
$request{ignoreredirects} = $ignoreredirects; $request{ignoreredirects} = $ignoreredirects;
$request{method} = $method if ($method);
my $qlen = ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0); my $qlen = ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0);
Log3 $name, 4, "$name: AddToQueue adds $request{type}, initial queue len: $qlen" . ($prio ? ", prio" : ""); #Log3 $name, 4, "$name: AddToQueue adds $request{type}, initial queue len: $qlen" . ($prio ? ", prio" : "");
Log3 $name, 5, "$name: AddToQueue " . ($prio ? "prepends " : "adds ") . Log3 $name, 5, "$name: AddToQueue " . ($prio ? "prepends " : "adds ") .
"type $request{type} to " . "type $request{type} to " .
"URL $request{url}, " . "URL $request{url}, " .
($request{data} ? "data $request{data}, " : "no data, ") . ($request{data} ? "data $request{data}, " : "no data, ") .
($request{header} ? "header $request{header}, " : "no headers, ") . ($request{header} ? "header $request{header}, " : "no headers, ") .
($request{ignoreredirects} ? "ignore redirects, " : "") . ($request{ignoreredirects} ? "ignore redirects, " : "") .
"retry $count"; "retry $count" .
", initial queue len: $qlen";
if(!$qlen) { if(!$qlen) {
$hash->{QUEUE} = [ \%request ]; $hash->{QUEUE} = [ \%request ];
} else { } else {
@ -3560,7 +3740,7 @@ sub HTTPMOD_AddToQueue($$$$$;$$$$){
</ul></code> </ul></code>
Every time the module tries to read from a device, it will also check if readings have not been updated Every time the module tries to read from a device, it will also check if readings have not been updated
for longer than the MaxAge attributes allow. If readings are outdated, the MaxAgeReplacementMode defines how the affected for longer than the MaxAge attributes allow. If readings are outdated, the MaxAgeReplacementMode defines how the affected
reading values should be replaced. MaxAgeReplacementMode can be <code>text</code>, <code>expression</code> or <code>delete</code>. <br> reading values should be replaced. MaxAgeReplacementMode can be <code>text</code>, <code>reading</code>, <code>internal</code>, <code>expression</code> or <code>delete</code>. <br>
MaxAge specifies the number of seconds that a reading should remain untouched before it is replaced. <br> MaxAge specifies the number of seconds that a reading should remain untouched before it is replaced. <br>
MaxAgeReplacement contains either a static text that is used as replacement value or a Perl expression that is evaluated to MaxAgeReplacement contains either a static text that is used as replacement value or a Perl expression that is evaluated to
give the replacement value. This can be used for example to replace a temperature that has not bee updated for more than 5 minutes give the replacement value. This can be used for example to replace a temperature that has not bee updated for more than 5 minutes
@ -3724,6 +3904,21 @@ sub HTTPMOD_AddToQueue($$$$$;$$$$){
This can be used if the device delivers strings in an encoding like cp850 and after decoding it you want to reencode it to e.g. utf8. This can be used if the device delivers strings in an encoding like cp850 and after decoding it you want to reencode it to e.g. utf8.
If your reading values contain Umlauts and they are shown as strange looking icons then you probably need to use this feature. If your reading values contain Umlauts and they are shown as strange looking icons then you probably need to use this feature.
Using this attribute for a set command only makes sense if you want to parse the HTTP response to the HTTP request that the set command sent by defining the attribute setXXParseResponse.<br> Using this attribute for a set command only makes sense if you want to parse the HTTP response to the HTTP request that the set command sent by defining the attribute setXXParseResponse.<br>
<li><b>bodyDecode</b></li>
defines an encoding to be used in a call to the perl function decode to convert the raw http response body data string read from the device before further processing / matching<br>
If you have trouble matching special characters or if your reading values contain Umlauts
and they are shown as strange looking icons then might need to use this feature.<br>
This attribute can be set to auto. HTTPMOD will then look for a charset header and decode the body acordingly. If no charset headr is found, the body will remain undecoded.
Starting with featurelevel > 5.9 HTTPMOD will use this feature as by default. So you don't need to set it to 'auto', but you can disable it by setting it to ''.
<br>
<li><b>regexDecode</b></li>
defines an encoding to be used in a call to the perl function decode to convert the raw data string from regex attributes before further processing / matching<br>
If you have trouble matching special characters or if you need to get around a memory leak in Perl regex processing this might help
<br>
<li><b>regexCompile</b></li>
defines that regular expressions will be precompiled when they are used for the first time and then stored internally so that subsequent uses of the same
regular expression will be faster. This option is turned on by default but setting this attribute to 0 will disable it.
<br>
<br> <br>
<li><b>(get|set)[0-9]*URL</b></li> <li><b>(get|set)[0-9]*URL</b></li>
@ -3732,6 +3927,8 @@ sub HTTPMOD_AddToQueue($$$$$;$$$$){
<li><b>(get|set)[0-9]*Data</b></li> <li><b>(get|set)[0-9]*Data</b></li>
optional data to be sent to the device as POST data when the get oer set command is executed. optional data to be sent to the device as POST data when the get oer set command is executed.
if this attribute is specified, an HTTP POST method will be sent instead of an HTTP GET if this attribute is specified, an HTTP POST method will be sent instead of an HTTP GET
<li><b>set[0-9]*Method</b></li>
HTTP Method (GET, POST or PUT) which shall be used for the set.
<li><b>(get|set)[0-9]*NoData</b></li> <li><b>(get|set)[0-9]*NoData</b></li>
can be used to override a more generic attribute that specifies POST data for all get commands. can be used to override a more generic attribute that specifies POST data for all get commands.
With NoData no data is sent and therefor the request will be an HTTP GET. With NoData no data is sent and therefor the request will be an HTTP GET.