mirror of
https://github.com/fhem/fhem-mirror.git
synced 2025-05-04 22:19:38 +00:00
98_HTTPMOD.pm: some new attributes, precompilation of regexes to avoid memory leak in some perl versions
git-svn-id: https://svn.fhem.de/fhem/trunk/fhem@20519 2b470e98-0d58-463d-a4d8-8e2adae1ed80
This commit is contained in:
StefanStrobel
parent
03413d7608
commit
b75c2cdc6f
@ -162,16 +162,20 @@
|
||||
# 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-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:
|
||||
#
|
||||
# extractAllReadings mit Filter / Prefix
|
||||
# add examples to the documentation of attributes
|
||||
# get after set um readings zu aktualisieren
|
||||
# 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.
|
||||
#
|
||||
# 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?
|
||||
# multi page log extraction?
|
||||
# Profiling von Modbus übernehmen?
|
||||
# extend httpmod to support simple tcp connections over devio instead of HttpUtils?
|
||||
#
|
||||
#
|
||||
# Merkliste fürs nächste Fhem Release
|
||||
@ -191,6 +194,7 @@
|
||||
# - enableCookies
|
||||
# - handleRedirects
|
||||
# - enableControlSet
|
||||
# - bodyDecode auto
|
||||
#
|
||||
#
|
||||
#
|
||||
@ -230,11 +234,11 @@ sub HTTPMOD_Get($@);
|
||||
sub HTTPMOD_Attr(@);
|
||||
sub HTTPMOD_GetUpdate($);
|
||||
sub HTTPMOD_Read($$$);
|
||||
sub HTTPMOD_AddToQueue($$$$$;$$$$);
|
||||
sub HTTPMOD_AddToQueue($$$$$;$$$$$);
|
||||
sub HTTPMOD_JsonFlatter($$;$);
|
||||
sub HTTPMOD_ExtractReading($$$$$);
|
||||
|
||||
my $HTTPMOD_Version = '3.5.9 - 13.2.2019';
|
||||
my $HTTPMOD_Version = '3.5.16 - 11.11.2019';
|
||||
|
||||
#
|
||||
# FHEM module intitialisation
|
||||
@ -269,7 +273,7 @@ sub HTTPMOD_Initialize($)
|
||||
"(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacement " .
|
||||
|
||||
"(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-Strict " .
|
||||
"(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)
|
||||
"[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]*Method:GET,POST,PUT " . # select HTTP method for the set
|
||||
|
||||
"reAuthRegex " .
|
||||
"reAuthAlways:0,1 " .
|
||||
@ -373,7 +378,13 @@ sub HTTPMOD_Initialize($)
|
||||
"enableXPath-Strict:0,1 " . # old
|
||||
"enforceGoodReadingNames " .
|
||||
"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
|
||||
"regexDecode " .
|
||||
"regexCompile " .
|
||||
"bodyDecode " .
|
||||
"regexCompile " .
|
||||
$readingFnAttributes;
|
||||
}
|
||||
|
||||
@ -403,7 +414,7 @@ sub HTTPMOD_SetTimer($;$)
|
||||
$hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger);
|
||||
RemoveInternalTimer("update:$name");
|
||||
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}";
|
||||
} else {
|
||||
$hash->{TRIGGERTIME} = 0;
|
||||
@ -526,26 +537,26 @@ sub HTTPMOD_ManageUserAttr($$)
|
||||
my $modHash = $modules{$hash->{TYPE}};
|
||||
|
||||
# handle wild card attributes -> Add to userattr to allow modification in fhemweb
|
||||
#Log3 $name, 3, "$name: attribute $aName checking ";
|
||||
if (" $modHash->{AttrList} " !~ m/ ${aName}[ :;]/) {
|
||||
# nicht direkt in der Liste -> evt. wildcard attr in AttrList
|
||||
foreach my $la (split " ", $modHash->{AttrList}) {
|
||||
$la =~ /([^:;]+)(:?.*)/;
|
||||
$la =~ /^([^:;]+)(:?.*)$/;
|
||||
my $vgl = $1; # attribute name in list - probably a regex
|
||||
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
|
||||
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) {
|
||||
# remove old entries without hint
|
||||
my $ualist = $attr{$name}{userattr};
|
||||
$ualist = "" if(!$ualist);
|
||||
my %uahash;
|
||||
foreach my $a (split(" ", $ualist)) {
|
||||
if ($a !~ /^${aName}$/) { # entry in userattr list is attribute without hint
|
||||
$uahash{$a} = 1;
|
||||
} else {
|
||||
Log3 $name, 3, "$name: added hint $opt to attr $a in userattr list";
|
||||
if ($a !~ /^${aName}$/) { # no match -> existing entry in userattr list is attribute without hint
|
||||
$uahash{$a} = 1; # put $a as key into the hash so it is kept in userattr later
|
||||
} else { # match -> in list without attr -> remove
|
||||
#Log3 $name, 5, "$name: ManageUserAttr removes attr $a without hint $opt from userattr list";
|
||||
}
|
||||
}
|
||||
$attr{$name}{userattr} = join(" ", sort keys %uahash);
|
||||
@ -562,6 +573,64 @@ 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
|
||||
#########################################################################
|
||||
@ -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 ($cmd eq "set") {
|
||||
if ($aName =~ /Regex/) { # catch all Regex like attributes
|
||||
my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT');
|
||||
$SIG{__WARN__} = sub { Log3 $name, 3, "$name: set attr $aName $aVal created warning: @_"; };
|
||||
eval {qr/$aVal/};
|
||||
$SIG{__WARN__} = $oldSig;
|
||||
if ($@) {
|
||||
Log3 $name, 3, "$name: Attr with invalid regex in attr $name $aName $aVal: $@";
|
||||
return "Invalid Regex $aVal";
|
||||
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
|
||||
#HTTPMOD_PrecompileRegexAttr($hash, $aName, $aVal);
|
||||
# precompile at first use and consider regopt with it.
|
||||
delete $hash->{CompiledRegexes}{$aName};
|
||||
Log3 $name, 4, "$name: Attr got regex attr -> delete potentially precompiled regex for $aName";
|
||||
|
||||
if ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex$/) {
|
||||
$hash->{ReplacementEnabled} = 1;
|
||||
}
|
||||
@ -607,7 +678,7 @@ sub HTTPMOD_Attr(@)
|
||||
Log3 $name, 3, "$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 $timeDiff = 0; # to be available in Exprs
|
||||
my @matchlist = ();
|
||||
@ -730,6 +801,7 @@ sub HTTPMOD_Attr(@)
|
||||
|
||||
} elsif ($aName =~ /^(reading|get)([0-9]+)(-[0-9]+)?Name$/) {
|
||||
$hash->{".updateRequestHash"} = 1;
|
||||
|
||||
}
|
||||
|
||||
my $err = HTTPMOD_ManageUserAttr($hash, $aName);
|
||||
@ -788,7 +860,10 @@ sub HTTPMOD_Attr(@)
|
||||
} elsif ($aName eq 'alignTime') {
|
||||
delete $hash->{TimeAlign};
|
||||
delete $hash->{TimeAlignFmt};
|
||||
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
if ($aName =~ /^[gs]et/ || $aName eq "enableControlSet") {
|
||||
$hash->{".updateHintList"} = 1;
|
||||
@ -1049,7 +1124,8 @@ sub HTTPMOD_Replace($$$)
|
||||
next if ($rr !~ /^replacement([0-9]*)Regex$/);
|
||||
my $rNum = $1;
|
||||
#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");
|
||||
next if (!$regex);
|
||||
|
||||
@ -1110,7 +1186,7 @@ sub HTTPMOD_Replace($$$)
|
||||
$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);
|
||||
}
|
||||
return $string;
|
||||
@ -1531,7 +1607,7 @@ sub HTTPMOD_Set($@)
|
||||
my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "set", $setNum);
|
||||
if ($url) {
|
||||
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 {
|
||||
Log3 $name, 3, "$name: no URL for set $setNum";
|
||||
}
|
||||
@ -1602,7 +1678,7 @@ sub HTTPMOD_GetUpdate($)
|
||||
my ($url, $header, $data, $count);
|
||||
my $now = gettimeofday();
|
||||
|
||||
Log3 $name, 4, "$name: GetUpdate called ($calltype)";
|
||||
Log3 $name, 5, "$name: GetUpdate called ($calltype)";
|
||||
|
||||
if ($calltype eq "update") {
|
||||
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
|
||||
###################################
|
||||
sub HTTPMOD_FormatReading($$$$$)
|
||||
@ -1873,7 +1992,7 @@ sub HTTPMOD_ExtractReading($$$$$)
|
||||
}
|
||||
# new syntax overrides reading and regex
|
||||
$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;
|
||||
|
||||
@ -1898,9 +2017,10 @@ sub HTTPMOD_ExtractReading($$$$$)
|
||||
}
|
||||
}
|
||||
@matchlist = (join ",", @matchlist); # old syntax returns only one value
|
||||
} else {
|
||||
# normal regex
|
||||
|
||||
} else { # normal regex
|
||||
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 ...";
|
||||
eval '@matchlist = ($buffer =~ /' . "$regex/$regopt" . ')';
|
||||
Log3 $name, 3, "$name: error in regex matching with regex option: $@" if ($@);
|
||||
@ -1910,7 +2030,7 @@ sub HTTPMOD_ExtractReading($$$$$)
|
||||
@matchlist = ($buffer =~ /$regex/);
|
||||
%namedRegexGroups = %+ if (%+);
|
||||
}
|
||||
Log3 $name, 5, "$name: " . @matchlist . " capture group(s), " .
|
||||
Log3 $name, 5, "$name: " . @matchlist . " matches, " .
|
||||
(%namedRegexGroups ? "named capture groups, " : "") .
|
||||
"matchlist = " . join ",", @matchlist if (@matchlist);
|
||||
}
|
||||
@ -1989,7 +2109,7 @@ sub HTTPMOD_ExtractReading($$$$$)
|
||||
my $eNum = $num . ($group ? "-".$group : "");
|
||||
$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 );
|
||||
# point from reading name back to the parsing definition as reading01 or get02 ...
|
||||
$hash->{defptr}{readingBase}{$subReading} = $context; # used to find maxAge attr
|
||||
@ -2024,7 +2144,7 @@ sub HTTPMOD_ExtractReading($$$$$)
|
||||
push @subrlist, $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 );
|
||||
# point from reading name back to the parsing definition as reading01 or get02 ...
|
||||
$hash->{defptr}{readingBase}{$subReading} = $context; # used to find maxAge attr
|
||||
@ -2052,7 +2172,7 @@ sub HTTPMOD_PullToFile($$$$)
|
||||
my $name = $hash->{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 $recombine = HTTPMOD_GetFAttr($name, "get", $num, "RecombineExpr");
|
||||
$recombine = '$1' if not ($recombine);
|
||||
@ -2375,13 +2495,17 @@ sub HTTPMOD_ExtractSid($$$$)
|
||||
my $name = $hash->{NAME};
|
||||
|
||||
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 $xpath = AttrVal($name, "idXPath", "");
|
||||
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);
|
||||
$xpath = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath", $xpath);
|
||||
$xpathst = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath-Strict", $xpathst);
|
||||
@ -2442,13 +2566,16 @@ sub HTTPMOD_CheckAuth($$$$$)
|
||||
my $name = $hash->{NAME};
|
||||
my $doAuth;
|
||||
|
||||
my $regex = AttrVal($name, "reAuthRegex", "");
|
||||
#my $regex = AttrVal($name, "reAuthRegex", "");
|
||||
my $regex = HTTPMOD_GetRegex($name, "", "", "reAuthRegex", "");
|
||||
|
||||
my $json = AttrVal($name, "reAuthJSON", "");
|
||||
my $xpath = AttrVal($name, "reAuthXPath", "");
|
||||
my $xpathst = AttrVal($name, "reAuthXPath-Strict", "");
|
||||
|
||||
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);
|
||||
$xpath = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthXPath", $xpath);
|
||||
$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?";
|
||||
}
|
||||
} else {
|
||||
Log3 $name, 4, "$name: CheckAuth decided no authentication required";
|
||||
Log3 $name, 5, "$name: CheckAuth decided no authentication required";
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
@ -2568,7 +2695,8 @@ sub HTTPMOD_CheckRedirects($$)
|
||||
return;
|
||||
}
|
||||
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_HandleSendQueue("direct:".$name); # AddToQueue with prio did not call this.
|
||||
return 1;
|
||||
@ -2603,7 +2731,7 @@ sub HTTPMOD_Read($$$)
|
||||
|
||||
if (!$name || $hash->{TYPE} ne "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;
|
||||
}
|
||||
|
||||
@ -2611,16 +2739,62 @@ sub HTTPMOD_Read($$$)
|
||||
Log3 $name, 3, "$name: Read callback: Error: $err" if ($err);
|
||||
Log3 $name, 4, "$name: Read callback: request type was $type" .
|
||||
" retry $request->{retryCount}" .
|
||||
#($header ? ",\r\nHeader: $header" : ", no headers") .
|
||||
($body ? ",\r\nBody: $body" : ", body empty");
|
||||
($header ? ",\r\nheader: $header" : ", no headers") .
|
||||
($body ? ", body length " . length($body) : ", no body");
|
||||
Log3 $name, 5, "$name: Read callback: " .
|
||||
($body ? "body\r\n$body" : "body empty");
|
||||
|
||||
$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) {
|
||||
my $pprexp = '$body=~' . $ppr;
|
||||
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;
|
||||
$SIG{__WARN__} = $oldSig;
|
||||
|
||||
@ -2767,10 +2941,11 @@ sub HTTPMOD_Read($$$)
|
||||
}
|
||||
|
||||
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 {
|
||||
Log3 $name, 4, "$name: Read response to $type matched Reading(s) " . join ' ', @matched;
|
||||
Log3 $name, 4, "$name: Read response to $type did not match " . join ' ', @unmatched if (@unmatched);
|
||||
Log3 $name, 4, "$name: Read response matched " . scalar(@matched) .", unmatch " . scalar(@unmatched) . " Reading(s)";
|
||||
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);
|
||||
@ -2849,6 +3024,10 @@ sub HTTPMOD_HandleSendQueue($)
|
||||
$hash->{value} = $hash->{REQUEST}{value};
|
||||
$hash->{timeout} = AttrVal($name, "timeout", 2);
|
||||
$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);
|
||||
if (AttrVal($name, "handleRedirects", $fDefault)) {
|
||||
$hash->{ignoreredirects} = 1; # HttpUtils should not follow redirects if we do it in HTTPMOD
|
||||
@ -2934,11 +3113,10 @@ sub HTTPMOD_HandleSendQueue($)
|
||||
}
|
||||
}
|
||||
|
||||
Log3 $name, 4, "$name: HandleSendQueue sends request type $hash->{REQUEST}{type} to " .
|
||||
"URL $hash->{url}, " .
|
||||
Log3 $name, 4, "$name: HandleSendQueue sends $hash->{REQUEST}{type} with timeout $hash->{timeout} to " .
|
||||
"$hash->{url}, " .
|
||||
($hash->{data} ? "\r\ndata: $hash->{data}, " : "No Data, ") .
|
||||
($hash->{header} ? "\r\nheader: $hash->{header}" : "No Header") .
|
||||
"\r\ntimeout $hash->{timeout}";
|
||||
($hash->{header} ? "\r\nheader: $hash->{header}" : "No Header");
|
||||
|
||||
shift(@{$queue}); # remove first element from queue
|
||||
HttpUtils_NonblockingGet($hash);
|
||||
@ -2955,8 +3133,8 @@ sub HTTPMOD_HandleSendQueue($)
|
||||
|
||||
|
||||
#####################################
|
||||
sub HTTPMOD_AddToQueue($$$$$;$$$$){
|
||||
my ($hash, $url, $header, $data, $type, $value, $count, $ignoreredirects, $prio) = @_;
|
||||
sub HTTPMOD_AddToQueue($$$$$;$$$$$){
|
||||
my ($hash, $url, $header, $data, $type, $value, $count, $ignoreredirects, $prio, $method) = @_;
|
||||
my $name = $hash->{NAME};
|
||||
|
||||
$value = 0 if (!$value);
|
||||
@ -2971,16 +3149,18 @@ sub HTTPMOD_AddToQueue($$$$$;$$$$){
|
||||
$request{value} = $value;
|
||||
$request{retryCount} = $count;
|
||||
$request{ignoreredirects} = $ignoreredirects;
|
||||
$request{method} = $method if ($method);
|
||||
|
||||
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 ") .
|
||||
"type $request{type} to " .
|
||||
"URL $request{url}, " .
|
||||
($request{data} ? "data $request{data}, " : "no data, ") .
|
||||
($request{header} ? "header $request{header}, " : "no headers, ") .
|
||||
($request{ignoreredirects} ? "ignore redirects, " : "") .
|
||||
"retry $count";
|
||||
"retry $count" .
|
||||
", initial queue len: $qlen";
|
||||
if(!$qlen) {
|
||||
$hash->{QUEUE} = [ \%request ];
|
||||
} else {
|
||||
@ -3560,7 +3740,7 @@ sub HTTPMOD_AddToQueue($$$$$;$$$$){
|
||||
</ul></code>
|
||||
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
|
||||
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>
|
||||
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
|
||||
@ -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.
|
||||
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>
|
||||
<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>
|
||||
|
||||
<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>
|
||||
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
|
||||
<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>
|
||||
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.
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user