From 28975d8ce004f7f256c1341b0a6e63d2e19e7cd3 Mon Sep 17 00:00:00 2001
From: StefanStrobel <>
Date: Sat, 13 Mar 2021 10:14:34 +0000
Subject: [PATCH] 98_HTTPMOD: small fixes
git-svn-id: https://svn.fhem.de/fhem/trunk@23943 2b470e98-0d58-463d-a4d8-8e2adae1ed80
---
fhem/FHEM/98_HTTPMOD.pm | 27 +++++-----
fhem/lib/FHEM/HTTPMOD/Utils.pm | 95 ++++++++++++++++++++++------------
2 files changed, 77 insertions(+), 45 deletions(-)
diff --git a/fhem/FHEM/98_HTTPMOD.pm b/fhem/FHEM/98_HTTPMOD.pm
index 8a3b390ec..3d5012360 100755
--- a/fhem/FHEM/98_HTTPMOD.pm
+++ b/fhem/FHEM/98_HTTPMOD.pm
@@ -141,7 +141,7 @@ BEGIN {
));
};
-my $Module_Version = '4.1.02 - 4.2.2021';
+my $Module_Version = '4.1.05 - 6.3.2021';
my $AttrList = join (' ',
'(reading|get|set)[0-9]+(-[0-9]+)?Name',
@@ -189,7 +189,7 @@ my $AttrList = join (' ',
'preProcessRegex',
'parseFunction1',
'parseFunction2',
- 'set[0-9]+Temp',
+ 'set[0-9]+Local', # don't create a request and just set a reading
'[gs]et[0-9]*URL',
'[gs]et[0-9]*Data.*',
'[gs]et[0-9]*NoData.*', # make sure it is an HTTP GET without data - even if a more generic data is defined
@@ -434,7 +434,7 @@ sub AttrFn {
my $cmd = shift; # 'set' or 'del'
my $name = shift; # the Fhem device name
my $aName = shift; # attribute name
- my $aVal = shift; # attribute value
+ my $aVal = shift // ''; # attribute value
my $hash = $defs{$name}; # reference to the Fhem device hash
Log3 $name, 5, "$name: attr $name $aName $aVal";
@@ -942,8 +942,8 @@ sub PrepareRequest {
}
#Log3 $name, 5, "$name: PrepareRequest got url $url, header $header and data $data";
$header = EvalExpr($hash, {expr => GetFAttr($name, $context, $num, "HdrExpr"), val => $header, action => 'HdrExpr'});
- $data = EvalExpr($hash, {expr => GetFAttr($name, $context, $num, "DatExpr"), val => $data, action => 'DatExpr'});
- $url = EvalExpr($hash, {expr => GetFAttr($name, $context, $num, "URLExpr"), val => $url, action => 'URLExpr'});
+ $data = EvalExpr($hash, {expr => GetFAttr($name, $context, $num, "DatExpr"), val => $data, action => 'DatExpr'});
+ $url = EvalExpr($hash, {expr => GetFAttr($name, $context, $num, "URLExpr"), val => $url, action => 'URLExpr'});
my $type;
if ($context eq 'reading') {
@@ -1254,7 +1254,7 @@ sub SetFn {
$rawVal = 0;
Log3 $name, 4, "$name: set will now set $setName";
}
- if (!AttrVal($name, "set${setNum}Temp", undef)) { # soll überhaupt ein Request erzeugt werden?
+ if (!AttrVal($name, "set${setNum}Local", undef)) { # soll überhaupt ein Request erzeugt werden?
my $request = PrepareRequest($hash, "set", $setNum);
if ($request->{'url'}) {
DoAuth $hash if (AttrVal($name, "reAuthAlways", 0));
@@ -1479,10 +1479,11 @@ sub FormatReading {
$expr = GetFAttr($name, $context, $num, "Expr", $expr) if ($context ne "set"); # not for set!
$expr = GetFAttr($name, $context, $num, "OExpr", $expr); # new syntax
- # if no encode is specified and bodyDecode did decode, then encode as utf8 by default
- #my $fDefault = ($featurelevel > 5.9 ? 'auto' : '');
- my $bodyDecode = AttrVal($name, 'bodyDecode', '');
- $encode = 'utf8' if (!$encode && $bodyDecode ne 'none');
+ # encode as utf8 by default if no encode is specified and body was decoded or no charset was seen in the header
+ if (!$encode && (!$hash->{'.bodyCharset'} || $hash->{'.bodyCharset'} eq 'internal' )) { # body was decoded and encode not sepcified
+ $encode = 'utf8';
+ Log3 $name, 5, "$name: FormatReading is encoding the reading value as utf-8 because no encoding was specified and the response body charset was unknown or decoded";
+ }
$val = decode($decode, $val) if ($decode && $decode ne 'none');
$val = encode($encode, $val) if ($encode && $encode ne 'none');
@@ -2276,7 +2277,7 @@ sub DumpBuffer {
my $fh;
$hash->{BufCounter} = 0 if (!$hash->{BufCounter});
$hash->{BufCounter} ++;
- my $path = AttrVal($name, "dumpBuffers", 0);
+ my $path = AttrVal($name, "dumpBuffers", '.');
Log3 $name, 3, "$name: dump buffer to $path/buffer$hash->{BufCounter}.txt";
open($fh, '>', "$path/buffer$hash->{BufCounter}.txt"); ## no critic
if ($header) {
@@ -2737,7 +2738,7 @@ sub AddToSendQueue {
attr PM reading02Name CL
attr PM reading02Regex 34.4008.value":[ \t]+"([\d\.]+)"
- attr PM reading03Name3TEMP
+ attr PM reading03Name TEMP
attr PM reading03Regex 34.4033.value":[ \t]+"([\d\.]+)"
attr PM requestData {"get" :["34.4001.value" ,"34.4008.value" ,"34.4033.value", "14.16601.value", "14.16602.value"]}
@@ -3469,6 +3470,8 @@ sub AddToSendQueue {
Defines that this set option doesn't require arguments. It allows sets like "on" or "off" without further values.
set[0-9]*ParseResponse
defines that the HTTP response to the set will be parsed as if it was the response to a get command.
+ set[0-9]*Local
+ defines that no HTTP request will be sent. Instead the value is directly set as a reading value.
(get|set)[0-9]*HdrExpr
diff --git a/fhem/lib/FHEM/HTTPMOD/Utils.pm b/fhem/lib/FHEM/HTTPMOD/Utils.pm
index e271ec0ea..55203b575 100644
--- a/fhem/lib/FHEM/HTTPMOD/Utils.pm
+++ b/fhem/lib/FHEM/HTTPMOD/Utils.pm
@@ -120,13 +120,13 @@ sub UpdateTimer {
if ($hash->{'.TRIGGERTIME'}) {
Log3 $name, 4, "$name: UpdateTimer called from " . FhemCaller() . " with cmd $cmd and interval $intvl stops timer";
delete $hash->{'.TRIGGERTIME'};
- #delete $hash->{TRIGGERTIME_FMT};
delete $hash->{'.LastUpdate'};
+ #delete $hash->{TRIGGERTIME_FMT};
}
return;
}
if ($cmd eq 'next') {
- $hash->{'.LastUpdate'} = $now; # start timer from now, ignore potential last update time
+ $hash->{'.LastUpdate'} = $now; # start timer from now, ignore potential last update time
}
my $nextUpdate;
if ($hash->{'.TimeAlign'}) { # TimeAlign: do as if interval started at time w/o drift ...
@@ -665,9 +665,12 @@ sub FlattenJSON {
eval { use JSON };
return if($@);
- my $decoded = eval { decode_json($buffer) };
+ my $decoded = eval { decode_json($buffer) };
+ my $cT = $hash->{'.Content-Type'} // '';
+ my $logLvl = ($cT =~ /json/i ? 3 : 4);
if ($@) {
- Log3 $name, 3, "$name: error while parsing JSON data: $@";
+ Log3 $name, $logLvl, "$name: error while parsing JSON data: $@";
+ #Log3 $name, 3, "$name: Content-Type was $cT";
}
else {
JsonFlatter($hash, $decoded);
@@ -682,47 +685,73 @@ sub FlattenJSON {
sub MemReading {
my $hash = shift;
my $name = $hash->{NAME}; # Fhem device name
- 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 (-e "/proc/$$/status") {
+ my $v = `awk '/VmSize/{print \$2}' /proc/$$/status`;
+ $v = sprintf("%.2f",(rtrim($v)/1024));
+ readingsBeginUpdate($hash);
+ readingsBulkUpdate ($hash, "Fhem_Mem", $v);
+ readingsBulkUpdate ($hash, "Fhem_BufCounter", $hash->{BufCounter}) if defined($hash->{BufCounter});
+ readingsEndUpdate($hash, 1);
+ Log3 $name, 5, "$name: Read checked virtual Fhem memory: " . $v . "MB" .
+ (defined($hash->{BufCounter}) ? ", BufCounter = $hash->{BufCounter}" : "");
+ } else {
+ Log3 $name, 5, "$name: MemReading only works under Linux";
+ }
return;
}
-##########################################
-# decode charset in a http response
+########################################################
+# get content-type and decode charset in a http response
sub BodyDecode {
my $hash = shift;
my $body = shift;
my $header = shift // '';
my $name = $hash->{NAME}; # Fhem device name
- my $fDefault = ($featurelevel > 5.9 ? 'auto' : '');
- my $bodyDecode = AttrVal($name, 'bodyDecode', $fDefault);
+ my $bodyDecode = AttrVal($name, 'bodyDecode', 'default');
+ my $bodyCharset;
+ my $decoding;
- if ($bodyDecode eq 'auto' or $bodyDecode eq 'Auto') {
- if ($header =~/Content-Type:.*charset=([\w\-\.]+)/i) {
- $bodyDecode = $1;
- Log3 $name, 4, "$name: BodyDecode found charset header and set decoding to $bodyDecode (bodyDecode was set to auto)";
- }
- else {
- $bodyDecode = "";
- Log3 $name, 4, "$name: BodyDecode found no charset header (bodyDecode was set to auto)";
- }
+ if ($header =~/Content-Type:(.*)/i) {
+ $hash->{'.Content-Type'} = $1;
}
- if ($bodyDecode) {
- if ($bodyDecode =~ m{\A [Nn]one \z}xms) {
- Log3 $name, 4, "$name: BodyDecode is not decoding the response body (set to none)";
- }
- else {
- $body = decode($bodyDecode, $body);
- Log3 $name, 4, "$name: BodyDecode is decoding the response body as $bodyDecode ";
+ if ($header =~/Content-Type:.*charset=([\w\-\.]+)/i) {
+ $bodyCharset = $1;
+ $hash->{'.bodyCharset'} = $bodyCharset;
+ }
+ else {
+ $bodyCharset = 'not found';
+ delete $hash->{'.bodyCharset'};
+ }
+
+ if ($bodyDecode =~ m{\A [Nn]one \z}xms) {
+ Log3 $name, 4, "$name: BodyDecode is not decoding the response body (charset $bodyCharset, bodyDecode set to none)";
+ }
+ elsif ($bodyDecode eq 'default') {
+ Log3 $name, 4, "$name: BodyDecode is not decoding the response body (charset $bodyCharset, bodyDecode defaults to none)";
+ }
+ elsif ($bodyDecode =~ m{\A [Aa]uto \z}xms) {
+ if ($bodyCharset eq 'not found') {
+ Log3 $name, 4, "$name: BodyDecode is not decoding the response body (charset header not found, bodyDecode set to auto)";
}
- #Log3 $name, 5, "$name: BodyDecode callback " . ($body ? "new body as utf-8 is: \n" . encode ('utf-8', $body) : "body empty");
+ else {
+ Log3 $name, 4, "$name: BodyDecode is decoding the response body as $bodyCharset (charset header $bodyCharset, bodyDecode set to auto)";
+ $decoding = $bodyCharset;
+ }
+ }
+ elsif (lower($bodyDecode) eq lower($bodyCharset)) {
+ Log3 $name, 4, "$name: BodyDecode is decoding the response body as $bodyDecode";
+ $decoding = $bodyCharset;
+ }
+ else {
+ Log3 $name, 4, "$name: BodyDecode is decoding the response body as $bodyDecode but charset header is $bodyCharset";
+ $decoding = $bodyCharset;
+ }
+
+ if ($decoding) {
+ $body = decode($decoding, $body);
+ $hash->{'.bodyCharset'} = 'internal';
+ #Log3 $name, 5, "$name: BodyDecode " . ($body ? "new body as utf-8 is: \n" . encode ('utf-8', $body) : "body empty");
}
return $body;
}