######################################################################### # $Id$ # fhem Modul für Geräte mit Web-Oberfläche / Webservices # # This file is part of fhem. # # Fhem is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # Fhem is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with fhem. If not, see . # ############################################################################## # Changelog: # # 2013-12-25 initial version # 2013-12-29 modified to use non blocking HTTP # 2014-1-1 modified to use attr instead of set to define internal parameters # 2014-1-6 extended error handling and added documentation # 2014-1-15 added readingsExpr to allow some computation on raw values before put in readings # 2014-3-13 added noShutdown and disable attributes # 2014-4-8 fixed noShutdown check # 2014-4-9 added Attribute timeout as suggested by Frank # 2014-10-22 added generic set function, alternative naming of old attributes, ... # 2014-11-17 added queueing for requests, fixed timeout # 2014-11-30 fixed race condition, added ignoreRedirects # an neues HttpUtils angepasst # 2014-12-05 definierte Attribute werden zu userattr der Instanz hinzugefügt # use $hash->{HTTPHEADER} or $hash->{httpheader} # 2014-12-22 Warnung in Set korrigiert # 2015-02-11 added attributes for a generic get feature, new get function, attributes "map" for readings, # modified the map attributes handling so it works with strings containing blanks # and splits at ", " or ":" # 2015-02-15 attribute to select readings per get # 2015-02-17 new attributes getXXRegex, Map, Format, Expr, new semantics for default values of these attributes # restructured HTTPMOD_Read # 2015-04-27 Integrated modification of jowiemann partially # settings: interval, reread, stop, start # DEVSTATE was not implemented because "disabled" is visible as attribute # and stopped / started is visible as TRIGGERTIME. # also the attribute disabled will not touch the internal timer. # 2015-05-10 Integrated xpath extension as suggested in the forum # 2015-06-22 added set[0-9]*NoArg and get[0-9]*URLExpr, get[0-9]*HeaderExpr and get[0-9]*DataExpr # 2015-07-30 added set[0-9]*TextArg, Encode and Decode # 2015-08-03 added get[0-9]*PullToFile (not fully implemented yet and not yet documented) # 2015-08-24 corrected bug when handling sidIdRegex for step <> 1 # 2015-09-14 implemented parseFunction1 and 2, modified to not return a value if successful # 2015-10-10 major restructuring, new xpath, xpath-strict and json parsing implementation # 2015-11-08 fixed bug which caused a recursion when reading from file:// urls # fixed xpath handling (so far ...) # 2015-11-19 MaxAge, aligned type and context for some functions # 2015-11-23 fixed map handling to allow spaces in names and convert them for fhemweb # 2015-12-03 Max age finalized # 2015-12-05 fixed error when loading Libs inside eval{} (should have been eval"") and added documentation for showError # 2015-12-07 fixed syntax to work with Perl older than 5.14 in a few places # added RecombineExpr and a few performance optimisations # 2015-12-10 fixed a bug in JSON parsing and corrected extractAllJSON to start with lower case # 2015-12-22 fixed missing error handling for JSON parser call # 2015-12-28 added SetParseResponse # 2016-01-01 fixed bug where httpheader was not handled, added cookie handling # 2016-01-09 fixed a bug which caused only one replacement per string to happen # 2016-01-10 fixed a bug where only the first word of text passed to set is used, # added sid extraction and reAuth detection with JSON and XPath # 2016-01-11 modified automatic $val replacement for set values to pass the value through the request queue and # do the actual replacement just before sending just like user definable replacements # so they can be done by replacement attributes with other placeholders instead # 2016-01-16 added TextArg to get and optimized creating the hint list for get / set ? # 2016-01-21 added documentation # added RegOpt (still needs more testing), Replacement mode delete # 2016-01-23 changed MATCHED_READINGS to contain automatically created subreadings (-num) # added AutoNumLen for automatic sub-reading names (multiple matches) # so the number has leading zeros and a fixed length # added new attribute upgrading mechanism (e.g. for sidIDRegex to sidIdRegex) # 2016-01-25 modified the way attributes are added to userattr - now includes :hints for fhemweb # and old entries are replaced # 2016-02-02 added more checks to JsonFlatter (if defined ...), fixed auth to be added in the front of the queue, # added clearSIdBeforeAuth, authRetries # 2016-02-04 added a feature to name a reading "unnamed-XX" if Name attribute is missing # instead of ignoring everything related # 2016-02-05 fixed a warning caused by missing initialisation of .setList internal # 2016-02-07 allowed more regular expression modifiers in RegOpt, added IMap / OMap / IExpr / OExpr # 2016-02-13 enable sslVersion attribute für HttpUtils and httpVersion # 2016-02-14 add sslArgs attribute - e.g. as attr myDevice sslArgs SSL_verify_mode,SSL_VERIFY_NONE # Log old attrs and offer set upgradeAttributes # 2016-02-15 added replacement type key and set storeKeyValue # 2016-02-20 set $XML::XPath::SafeMode = 1 to avoid memory leak in XML parser lib # 2016-03-25 started fixing array handling in json flatter # 2016-03-28 during extractAllJSON reading definitions will not be used to format readings. # Instead after the ExtractAllJSION loop # individual readings will be extracted (checkAll) and recombined if necessary # Fixed cookie handling to add cookies in HandleSendQueue instead of PrepareRequest # 2016-04-08 fixed usage of "keys" on reference in 1555 and 1557 # 2016-04-10 added readings UNMATCHED_READINGS and LAST_REQUEST if showMatched is set. # added AlwaysNum to force names anding with a number even if just one value is found # 2016-04-16 fixed typos in logging # 2016-04-24 Implemented DeleteOnError and DeleteIfUnmatched, # fixed an error in the cookie handling # 2016-05-08 Implemented alignTime, more MaxAgeReplacementMode varieties # fixed bug in Timer handling if Main URL was not specified in define # 2016-05-20 3.2.2 UpdateRequestHash for DeleteIf / DeleteOn / MaxAge # foreach / grep usage optimized in Replace, UpdateHintList, UpdateRequesthash, UpdateReadingList, GetUpdate # Poll handling fixed (poll = 0) in GetUpdate # Optimized keylist in json handling in ExtractReading # Regexes optimized (^$) # Module Version internal # Fixed attr regex for poll, pollDelay, replacements, # typos in Auth, UpdateHintList after define, # details im ExtractReading for requestReading hash # LAST_REQUEST bei Error in Read # fixed call to CheckAuth - pass buffer instead of body # restructured _Read # modified CheckAuth to do auth also for json / xpath matches # Map, Format, Expr as well as Encode and Decode attributes will # be applied to ExtractAllJSON as well (e.g. getXXEncode or readingEncode) # 2016-06-02 switched from "each" to foreach in JsonFlatter when used on an array to support older Perl # fixed a warning in Getupdate when calculating with pollDelay # fixed double LAST_REQUEST # allow control_sets if disabled # fixed a bug in updateRequestHash (wrong request setting) # 2016-06-05 added code to recover if HttpUtils does not call back _read in timeout # 2016-06-28 added remark about dnsServer to documentation # 2016-07-03 fixed typos # 2016-07-18 make $now and $timeDiff available to OExpr # 2016-08-31 only fixed typos # 2016-09-20 fixed bugs where extractAllJSON filled requestReadings hash with wrong key and # requestReadings structure was filled with wrong data in updateRequestHash # optimized deletion of readings with their metadata, check $buffer before jsonflatter # 2016-10-02 changed logging in _Read: shorter log on level 3 if $err and details only on level 4 # 2016-10-06 little modification to help debugging a strange syntax error # 2017-02-08 fix bug in xpath handling reported in https://forum.fhem.de/index.php/topic,45176.315.html # catch warnings in evals - to be finished (drop subroutine and add inline) # 2017-03-16 Log line removed in JsonFlatter (creates warning if $value is not defined and it is not needed anyways) # 2017-03-23 new attribute removeBuf # 2017-05-07 fixed typo in documentation # 2017-05-08 optimized warning signal handling # 2017-05-09 fixed character encoding of source file for documentation # fixed a bug where updateRequestHash was not called after restart and for MaxAge # fixed a warning when alwaysNum without NumLen is specified # 2017-09-06 new attribute reAuthAlways to do the defined authentication steps # before each get / set / getupdate regardless of any reAuthRegex setting or similar. # 2018-01-18 added preProcessRegex e.g. to fix broken JSON data in a response # 2018-02-10 modify handling of attribute removeBuf since httpUtils doesn't expose its buffer anymore, # Instead new attribute showBody to explicitely show a formatted version of the http response body (header is already shown) # 2018-05-01 new attribute enforceGoodReadingNames # 2018-05-05 experimental support for named groups in regexes (won't support individual MaxAge / deleteIf attributes) # see ExtractReading function # 2018-07-01 own redirect handling, support for cookies with different paths / options # new attributes dontRequeueAfterAuth, handleRedirects # 2018-08-11 put userAttr handling in a subroutine # 2018-08-30 put map nandling in subroutines # 2018-11-09 changed regex to parse set-cookie # 2018-27-12 setExtensions (including attrTemplates) testweise eingebaut # 2019-01-09 useSetExtensions attribute to be able to disable setExtensions (by default they are now integrated) # 2019-01-12 special handling when extractAllJSON is set to 2 # 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 # 2019-11-17 remove unused function, reformat # 2019-11-19 little bug fixes # 2019-11-20 precompilation of preProcessRegex removed - can't compile a regex inluding a replacement part for s// # 2019-11-29 new fix for special compiled regexes with regex options # 2019-12-27 delete hash-{method} if not explicitely set # 2020-02-07 delete $hash->{httpbody} when showBody is set to 0 or deleted # # # # Todo: # setXYHintExpression zum dynamischen Ändern / Erweitern der Hints # extractAllReadings mit Filter / Prefix # 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) # featureAttrs aus hash verarbeiten # # Implement IMap und IExpr for get # # replacement scope attribute? # make extracting the sid after a get / update an attribute / option? # multi page log extraction? # Profiling von Modbus übernehmen? # # # Merkliste fürs nächste Fhem Release # - enforceGoodReadingNames 1 als Default # - enableCookies # - handleRedirects # - enableControlSet # - bodyDecode auto # # # # verwendung von defptr: # $hash->{defptr}{readingBase}{$reading} gibt zu einem Reading-Namen den Ursprung an, z.B. get oder reading # readingNum die zugehörige Nummer, z.B. 01 # readingSubNum ggf. eine Unternummer (bei reading01-001) # wird von MaxAge verwendet um schnell zu einem Reading die zugehörige MaxAge Definition finden zu können # # $hash->{defptr}{requestReadings}{$reqType}{$baseReading} # wird von DeleteOnError und DeleteIfUnmatched verwendet. # $reqType ist update, get01, set01 etc. # $baseReading ist der Reading Basisname wie im Attribute ...Name definiert, # aber ohne eventuelle Extension bei mehreren Matches. # Liefert "$context $num", also z.B. get 1 - dort wird nach DeleteOn.. gesucht # wichtig um z.B. von reqType "get01" baseReading "Temperatur" auf reading 02 zu kommen # falls get01 keine eigenen parsing definitions enthält # DeleteOn... wird dann beim reading 02 etc. spezifiziert. # package main; use strict; use warnings; use Time::HiRes qw(gettimeofday); use Encode qw(decode encode); use HttpUtils; use SetExtensions qw/ :all /; sub HTTPMOD_Initialize($); sub HTTPMOD_Define($$); sub HTTPMOD_Undef($$); sub HTTPMOD_Set($@); sub HTTPMOD_Get($@); sub HTTPMOD_Attr(@); sub HTTPMOD_GetUpdate($); sub HTTPMOD_Read($$$); sub HTTPMOD_AddToQueue($$$$$;$$$$$); sub HTTPMOD_JsonFlatter($$;$); sub HTTPMOD_ExtractReading($$$$$); my $HTTPMOD_Version = '3.5.22 - 7.2.2020'; ######################################################################### # FHEM module intitialisation # defines the functions to be called from FHEM sub HTTPMOD_Initialize($) { my ($hash) = @_; $hash->{DefFn} = "HTTPMOD_Define"; $hash->{UndefFn} = "HTTPMOD_Undef"; $hash->{SetFn} = "HTTPMOD_Set"; $hash->{GetFn} = "HTTPMOD_Get"; $hash->{AttrFn} = "HTTPMOD_Attr"; $hash->{NotifyFn} = "HTTPMOD_Notify"; $hash->{AttrList} = "(reading|get|set)[0-9]+(-[0-9]+)?Name " . "(reading|get|set)[0-9]*(-[0-9]+)?Expr " . "(reading|get|set)[0-9]*(-[0-9]+)?Map " . "(reading|get|set)[0-9]*(-[0-9]+)?OExpr " . "(reading|get|set)[0-9]*(-[0-9]+)?OMap " . "(get|set)[0-9]*(-[0-9]+)?IExpr " . "(get|set)[0-9]*(-[0-9]+)?IMap " . "(reading|get|set)[0-9]*(-[0-9]+)?Format " . "(reading|get|set)[0-9]*(-[0-9]+)?Decode " . "(reading|get|set)[0-9]*(-[0-9]+)?Encode " . "(reading|get)[0-9]*(-[0-9]+)?MaxAge " . "(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacementMode:text,reading,internal,expression,delete " . "(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]+XPath " . "(reading|get|set)[0-9]+XPath-Strict " . "(reading|get|set)[0-9]+JSON " . "(reading|get|set)[0-9]*RecombineExpr " . "(reading|get|set)[0-9]*AutoNumLen " . "(reading|get|set)[0-9]*AlwaysNum " . "(reading|get|set)[0-9]*DeleteIfUnmatched " . "(reading|get|set)[0-9]*DeleteOnError " . "extractAllJSON:0,1,2 " . "extractAllJSONFilter " . "readingsName.* " . # old "readingsRegex.* " . # old "readingsExpr.* " . # old "requestHeader.* " . "requestData.* " . "noShutdown:0,1 " . "httpVersion " . "sslVersion " . "sslArgs " . "timeout " . "queueDelay " . "queueMax " . "alignTime " . "minSendDelay " . "showMatched:0,1 " . "showError:0,1 " . "showBody:0,1 " . # expose the http response body as internal #"removeBuf:0,1 " . # httpUtils doesn't expose buf anymore "preProcessRegex " . "parseFunction1 " . "parseFunction2 " . "[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 "[gs]et[0-9]*Header.* " . "[gs]et[0-9]*CheckAllReadings:0,1 " . "[gs]et[0-9]*ExtractAllJSON:0,1,2 " . "[gs]et[0-9]*URLExpr " . # old "[gs]et[0-9]*DatExpr " . # old "[gs]et[0-9]*HdrExpr " . # old "get[0-9]*Poll:0,1 " . "get[0-9]*PollDelay " . "get[0-9]*PullToFile " . "get[0-9]*PullIterate " . "set[0-9]+Min " . # todo: min, max und hint auch für get, Schreibweise der Liste auf (get|set) vereinheitlichen "set[0-9]+Max " . "set[0-9]+Hint " . # Direkte Fhem-spezifische Syntax für's GUI, z.B. "6,10,14" bzw. slider etc. "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 " . "reAuthJSON " . "reAuthXPath " . "reAuthXPath-Strict " . "[gs]et[0-9]*ReAuthRegex " . "[gs]et[0-9]*ReAuthJSON " . "[gs]et[0-9]*ReAuthXPath " . "[gs]et[0-9]*ReAuthXPath-Strict " . "idRegex " . "idJSON " . "idXPath " . "idXPath-Strict " . "(get|set|sid)[0-9]*IDRegex " . # old "(get|set|sid)[0-9]*IdRegex " . "(get|set|sid)[0-9]*IdJSON " . "(get|set|sid)[0-9]*IdXPath " . "(get|set|sid)[0-9]*IdXPath-Strict " . "sid[0-9]*URL " . "sid[0-9]*Header.* " . "sid[0-9]*Data.* " . "sid[0-9]*IgnoreRedirects:0,1 " . "sid[0-9]*ParseResponse:0,1 " . # parse response as if it was a get "clearSIdBeforeAuth:0,1 " . "authRetries " . "replacement[0-9]+Regex " . "replacement[0-9]+Mode:reading,internal,text,expression,key " . # defaults to text "replacement[0-9]+Value " . # device:reading, device:internal, text, replacement expression "[gs]et[0-9]*Replacement[0-9]+Value " . # can overwrite a global replacement value - todo: auch für auth? "do_not_notify:1,0 " . "disable:0,1 " . "enableControlSet:0,1 " . "enableCookies:0,1 " . "useSetExtensions:1,0 ". "handleRedirects:0,1 " . # own redirect handling outside HttpUtils "enableXPath:0,1 " . # old "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; } ######################################################################### # Setze GetUpdate-Timer und berücksichtige TimeAlign sub HTTPMOD_SetTimer($;$) { my ($hash, $start) = @_; my $nextTrigger; my $name = $hash->{NAME}; my $now = gettimeofday(); $start = 0 if (!$start); if ($hash->{Interval}) { if ($hash->{TimeAlign}) { my $count = int(($now - $hash->{TimeAlign} + $start) / $hash->{Interval}); my $curCycle = $hash->{TimeAlign} + $count * $hash->{Interval}; $nextTrigger = $curCycle + $hash->{Interval}; } else { $nextTrigger = $now + ($start ? $start : $hash->{Interval}); } $hash->{TRIGGERTIME} = $nextTrigger; $hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger); RemoveInternalTimer("update:$name"); InternalTimer($nextTrigger, "HTTPMOD_GetUpdate", "update:$name", 0); Log3 $name, 5, "$name: update timer modified: will call GetUpdate in " . sprintf ("%.1f", $nextTrigger - $now) . " seconds at $hash->{TRIGGERTIME_FMT}"; } else { $hash->{TRIGGERTIME} = 0; $hash->{TRIGGERTIME_FMT} = ""; } } ######################################################################### # Define command # init internal values, # set internal timer get Updates sub HTTPMOD_Define($$) { my ($hash, $def) = @_; my @a = split( "[ \t]+", $def ); return "wrong syntax: define HTTPMOD URL interval" if ( @a < 3 ); my $name = $a[0]; if ($a[2] eq "none") { Log3 $name, 3, "$name: URL is none, periodic updates will be limited to explicit GetXXPoll attribues (if defined)"; $hash->{MainURL} = ""; } else { $hash->{MainURL} = $a[2]; } if(int(@a) > 3) { # interval specified if ($a[3] > 0) { if ($a[3] >= 5) { $hash->{Interval} = $a[3]; } else { return "interval too small, please use something > 5, default is 300"; } } else { Log3 $name, 3, "$name: interval is 0, no periodic updates will done."; $hash->{Interval} = 0; } } else { # default if no interval specified $hash->{Interval} = 300; } Log3 $name, 3, "$name: Defined " . ($hash->{MainURL} ? "with URL $hash->{MainURL}" : "without URL") . ($hash->{Interval} ? " and interval $hash->{Interval}" : "") . " featurelevel $featurelevel"; HTTPMOD_SetTimer($hash, 2); # first Update in 2 seconds or aligned $hash->{NOTIFYDEV} = "global"; # NotifyFn nur aufrufen wenn global events (INITIALIZED) $hash->{ModuleVersion} = $HTTPMOD_Version; $hash->{".getList"} = ""; $hash->{".setList"} = ""; $hash->{".updateHintList"} = 1; $hash->{".updateReadingList"} = 1; $hash->{".updateRequestHash"} = 1; return undef; } ######################################################################### # undefine command when device is deleted sub HTTPMOD_Undef($$) { my ($hash, $arg) = @_; my $name = $hash->{NAME}; RemoveInternalTimer ("timeout:$name"); RemoveInternalTimer ("queue:$name"); RemoveInternalTimer ("update:$name"); return undef; } ############################################################## # Notify Funktion - reagiert auf Änderung des Featurelevel sub HTTPMOD_Notify($$) { my ($hash, $source) = @_; return if($source->{NAME} ne "global"); my $events = deviceEvents($source, 1); return if(!$events); my $name = $hash->{NAME}; #Log3 $name, 5, "$name: Notify called for source $source->{NAME} with events: @{$events}"; foreach my $event (@{$events}) { #Log3 $name, 5, "$name: event $event"; if ($event =~ /ATTR global featurelevel/) { $hash->{".updateHintList"} = 1; } } #return if (!grep(m/^INITIALIZED|REREADCFG|(MODIFIED $name)|(DEFINED $name)$/, @{$source->{CHANGED}})); # DEFINED is not triggered if init is not done. return; } ######################################################################### sub HTTPMOD_LogOldAttr($$;$) { my ($hash, $old, $new) = @_; my $name = $hash->{NAME}; Log3 $name, 3, "$name: the attribute $old should no longer be used." . ($new ? " Please use $new instead" : ""); Log3 $name, 3, "$name: For most old attributes you can specify enableControlSet and then set device upgradeAttributes to automatically modify the configuration"; } ######################################################################### # setzt userAttr-Attribute bei Regex-Attrs sub HTTPMOD_ManageUserAttr($$) { my ($hash, $aName) = @_; my $name = $hash->{NAME}; my $modHash = $modules{$hash->{TYPE}}; # handle wild card attributes -> Add to userattr to allow modification in fhemweb if (" $modHash->{AttrList} " !~ m/ ${aName}[ :;]/) { # nicht direkt in der Liste -> evt. wildcard attr in AttrList foreach my $la (split " ", $modHash->{AttrList}) { $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 # $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}$/) { # 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); } } } } else { # exakt in Liste enthalten -> sicherstellen, dass keine +* etc. drin sind. if ($aName =~ /\|\*\+\[/) { Log3 $name, 3, "$name: Atribute $aName is not valid. It still contains wildcard symbols"; return "$name: Atribute $aName is not valid. It still contains wildcard symbols"; } } } ################################### # 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$/) { # get context and num so we can look for corespondig regOpt attribute 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 } my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: PrecompileRegexAttr for $aName $aVal created warning: @_"; }; if ($regopt) { eval "\$hash->{CompiledRegexes}{\$aName} = qr/$aVal/$regopt"; # some options need to be compiled in - special syntax needed -> better formulate options as part of regex ... } else { eval {$hash->{CompiledRegexes}{$aName} = qr/$aVal/}; # no options - use easy way. } $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}"; } } } ######################################################################### # Attr command sub HTTPMOD_Attr(@) { my ($cmd,$name,$aName,$aVal) = @_; my $hash = $defs{$name}; my ($sid, $old); # might be needed inside a URLExpr # $cmd can be "del" or "set" # $name is device name # aName and aVal are attribute name and attribute value # simple attributes like requestHeader and requestData need no special treatment here # readingsExpr, readingsRegex.* or reAuthRegex need validation though. # if validation fails, return something so CommandAttr in fhem.pl doesn't assign a value to $attr 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 delete $hash->{CompiledRegexes}{$aName}; Log3 $name, 4, "$name: Attr got regex attr -> delete potentially precompiled regex for $aName"; # check if Regex is valid 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 =~ /([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex$/) { $hash->{ReplacementEnabled} = 1; } # conversions for legacy things if ($aName =~ /(.+)IDRegex$/) { HTTPMOD_LogOldAttr($hash, $aName, "${1}IdRegex"); } if ($aName =~ /readingsRegex.*/) { HTTPMOD_LogOldAttr($hash, $aName, "reading01Regex syntax"); } } elsif ($aName =~ /readingsName.*/) { HTTPMOD_LogOldAttr($hash, $aName, "reading01Name syntax"); } elsif ($aName =~ /RegOpt$/) { if ($aVal !~ /^[msxdualsig]*$/) { Log3 $name, 3, "$name: illegal RegOpt in attr $name $aName $aVal"; return "$name: illegal RegOpt in attr $name $aName $aVal"; } } elsif ($aName =~ /Expr/) { my $val = 0; my $old = 0; my $timeDiff = 0; # to be available in Exprs my @matchlist = (); no warnings qw(uninitialized); my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: set attr $aName $aVal created warning: @_"; }; eval $aVal; $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: Attr with invalid Expression in attr $name $aName $aVal: $@"; return "Invalid Expression $aVal"; } if ($aName =~ /readingsExpr.*/) { HTTPMOD_LogOldAttr($hash, $aName, "reading01Expr syntax"); } elsif ($aName =~ /^(get[0-9]*)Expr/) { HTTPMOD_LogOldAttr($hash, $aName, "${1}OExpr"); } elsif ($aName =~ /^(reading[0-9]*)Expr/) { HTTPMOD_LogOldAttr($hash, $aName, "${1}OExpr"); } elsif ($aName =~ /^(set[0-9]*)Expr/) { HTTPMOD_LogOldAttr($hash, $aName, "${1}IExpr"); } } elsif ($aName =~ /Map$/) { if ($aName =~ /^(get[0-9]*)Map/) { HTTPMOD_LogOldAttr($hash, $aName, "${1}OMap"); } elsif ($aName =~ /^(reading[0-9]*)Map/) { HTTPMOD_LogOldAttr($hash, $aName, "${1}OMap"); } elsif ($aName =~ /^(set[0-9]*)Map/) { HTTPMOD_LogOldAttr($hash, $aName, "${1}IMap"); } } elsif ($aName =~ /replacement[0-9]*Mode/) { if ($aVal !~ /^(reading|internal|text|expression|key)$/) { Log3 $name, 3, "$name: illegal mode in attr $name $aName $aVal"; return "$name: illegal mode in attr $name $aName $aVal"; } } elsif ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement([0-9]*)Value/) { Log3 $name, 5, "$name: validating attr $name $aName $aVal"; if (AttrVal($name, "replacement${2}Mode", "text") eq "expression") { no warnings qw(uninitialized); my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: set attr $aName $aVal created warning: @_"; }; eval $aVal; $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: Attr with invalid Expression (mode is expression) in attr $name $aName $aVal: $@"; return "Attr with invalid Expression (mode is expression) in attr $name $aName $aVal: $@"; } } } elsif ($aName =~ /(get|reading)[0-9]*JSON$/ || $aName =~ /[Ee]xtractAllJSON$/ || $aName =~ /[Rr]eAuthJSON$/ || $aName =~ /[Ii]dJSON$/) { eval "use JSON"; if($@) { return "Please install JSON Library to use JSON (apt-get install libjson-perl) - error was $@"; } $hash->{JSONEnabled} = 1; } elsif ($aName eq "enableCookies") { if ($aVal eq "0") { delete $hash->{HTTPCookieHash}; } } elsif ($aName eq "showBody") { if ($aVal eq "0") { delete $hash->{httpbody}; } } elsif ($aName eq "enableXPath" || $aName =~ /(get|reading)[0-9]+XPath$/ || $aName =~ /[Rr]eAuthXPath$/ || $aName =~ /[Ii]dXPath$/) { eval "use HTML::TreeBuilder::XPath"; if($@) { return "Please install HTML::TreeBuilder::XPath to use the xpath-Option (apt-get install libxml-TreeBuilder-perl libhtml-treebuilder-xpath-perl) - error was $@"; } $hash->{XPathEnabled} = ($aVal ? 1 : 0); } elsif ($aName eq "enableXPath-Strict" || $aName =~ /(get|reading)[0-9]+XPath-Strict$/ || $aName =~ /[Rr]eAuthXPath-Strict$/ || $aName =~ /[Ii]dXPath-Strict$/) { eval "use XML::XPath;use XML::XPath::XMLParser"; if($@) { return "Please install XML::XPath and XML::XPath::XMLParser to use the xpath-strict-Option (apt-get install libxml-parser-perl libxml-xpath-perl) - error was $@"; } $XML::XPath::SafeMode = 1; $hash->{XPathStrictEnabled} = ($aVal ? 1 : 0); } elsif ($aName =~ /^(reading|get)[0-9]*(-[0-9]+)?MaxAge$/) { if ($aVal !~ '([0-9]+)') { Log3 $name, 3, "$name: wrong format in attr $name $aName $aVal"; return "Invalid Format $aVal in $aName"; } $hash->{MaxAgeEnabled} = 1; } elsif ($aName =~ /^(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacementMode$/) { if ($aVal !~ /^(text|reading|internal|expression|delete)$/) { Log3 $name, 3, "$name: illegal mode in attr $name $aName $aVal"; return "$name: illegal mode in attr $name $aName $aVal, choose on of text, expression"; } } elsif ($aName =~ /^(reading|get|set)[0-9]*(-[0-9]+)?DeleteOnError$/) { if ($aVal !~ '([0-9]+)') { Log3 $name, 3, "$name: wrong format in attr $name $aName $aVal"; return "Invalid Format $aVal in $aName"; } $hash->{DeleteOnError} = ($aVal ? 1 : 0); } elsif ($aName =~ /^(reading|get|set)[0-9]*(-[0-9]+)?DeleteIfUnmatched$/) { if ($aVal !~ '([0-9]+)') { Log3 $name, 3, "$name: wrong format in attr $name $aName $aVal"; return "Invalid Format $aVal in $aName"; } $hash->{DeleteIfUnmatched} = ($aVal ? 1 : 0); } elsif ($aName eq 'alignTime') { my ($alErr, $alHr, $alMin, $alSec, undef) = GetTimeSpec($aVal); return "Invalid Format $aVal in $aName : $alErr" if ($alErr); my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(); $hash->{TimeAlign} = fhemTimeLocal($alSec, $alMin, $alHr, $mday, $mon, $year); $hash->{TimeAlignFmt} = FmtDateTime($hash->{TimeAlign}); HTTPMOD_SetTimer($hash, 2); # change timer for alignment but at least 2 secs from now } elsif ($aName =~ /^(reading|get)([0-9]+)(-[0-9]+)?Name$/) { $hash->{".updateRequestHash"} = 1; } my $err = HTTPMOD_ManageUserAttr($hash, $aName); return $err if ($err); # Deletion of Attributes } elsif ($cmd eq "del") { #Log3 $name, 5, "$name: del attribute $aName"; if ($aName =~ /(reading|get)[0-9]*JSON$/ || $aName =~ /[Ee]xtractAllJSON$/ || $aName =~ /[Rr]eAuthJSON$/ || $aName =~ /[Ii]dJSON$/) { if (!(grep !/$aName/, grep (/((reading|get)[0-9]*JSON$)|[Ee]xtractAllJSON$|[Rr]eAuthJSON$|[Ii]dJSON$/, keys %{$attr{$name}}))) { delete $hash->{JSONEnabled}; } } elsif ($aName eq "enableXPath" || $aName =~ /(get|reading)[0-9]+XPath$/ || $aName =~ /[Rr]eAuthXPath$/ || $aName =~ /[Ii]dXPath$/) { if (!(grep !/$aName/, grep (/(get|reading)[0-9]+XPath$|enableXPath|[Rr]eAuthXPath$|[Ii]dXPath$/, keys %{$attr{$name}}))) { delete $hash->{XPathEnabled}; } } elsif ($aName eq "enableXPath-Strict" || $aName =~ /(get|reading)[0-9]+XPath-Strict$/ || $aName =~ /[Rr]eAuthXPath-Strict$/ || $aName =~ /[Ii]dXPath-Strict$/) { if (!(grep !/$aName/, grep (/(get|reading)[0-9]+XPath-Strict$|enableXPath-Strict|[Rr]eAuthXPath-Strict$|[Ii]dXPath-Strict$/, keys %{$attr{$name}}))) { delete $hash->{XPathStrictEnabled}; } } elsif ($aName eq "enableCookies") { delete $hash->{HTTPCookieHash}; } elsif ($aName eq "showBody") { delete $hash->{httpbody}; } elsif ($aName =~ /(reading|get)[0-9]*(-[0-9]+)?MaxAge$/) { if (!(grep !/$aName/, grep (/(reading|get)[0-9]*(-[0-9]+)?MaxAge$/, keys %{$attr{$name}}))) { delete $hash->{MaxAgeEnabled}; } } elsif ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex/) { if (!(grep !/$aName/, grep (/([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex/, keys %{$attr{$name}}))) { delete $hash->{ReplacementEnabled}; } } elsif ($aName =~ /^(reading|get|set)[0-9]*(-[0-9]+)?DeleteOnError$/) { if (!(grep !/$aName/, grep (/^(reading|get|set)[0-9]*(-[0-9]+)?DeleteOnError$/, keys %{$attr{$name}}))) { delete $hash->{DeleteOnError}; } } elsif ($aName =~ /^(reading|get|set)[0-9]*(-[0-9]+)?DeleteIfUnmatched$/) { if (!(grep !/$aName/, grep (/^(reading|get|set)[0-9]*(-[0-9]+)?DeleteIfUnmatched$/, keys %{$attr{$name}}))) { delete $hash->{DeleteIfUnmatched}; } } elsif ($aName eq 'alignTime') { delete $hash->{TimeAlign}; delete $hash->{TimeAlignFmt}; } } if ($aName =~ /^[gs]et/ || $aName eq "enableControlSet") { $hash->{".updateHintList"} = 1; } if ($aName =~ /^(get|reading)/) { $hash->{".updateReadingList"} = 1; } return undef; } ############################################## # Upgrade attribute names from older versions sub HTTPMOD_UpgradeAttributes($) { my ($hash) = @_; my $name = $hash->{NAME}; my %dHash; my %numHash; foreach my $aName (keys %{$attr{$name}}) { if ($aName =~ /(.+)IDRegex$/) { my $new = $1 . "IdRegex"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); # also adds new attr to userattr list through _Attr function CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } elsif ($aName =~ /(.+)Regex$/) { my $ctx = $1; my $val = $attr{$name}{$aName}; #Log3 $name, 3, "$name: upgradeAttributes check attr $aName, val $val"; if ($val =~ /^xpath:(.*)/) { $val = $1; my $new = $ctx . "XPath"; CommandAttr(undef, "$name $new $val"); CommandAttr(undef, "$name $ctx" . "RecombineExpr join(\",\", \@matchlist)"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } if ($val =~ /^xpath-strict:(.*)/) { $val = $1; my $new = $ctx . "XPath-Strict"; CommandAttr(undef, "$name $new $val"); CommandAttr(undef, "$name $ctx" . "RecombineExpr join(\",\", \@matchlist)"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } } elsif ($aName eq "enableXPath" || $aName eq "enableXPath-Strict" ) { CommandDeleteAttr(undef, "$name $aName"); Log3 $name, 3, "$name: removed attribute name $aName"; } elsif ($aName =~ /(set[0-9]*)Expr$/) { my $new = $1 . "IExpr"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } elsif ($aName =~ /(get[0-9]*)Expr$/) { my $new = $1 . "OExpr"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } elsif ($aName =~ /(reading[0-9]*)Expr$/) { my $new = $1 . "OExpr"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } elsif ($aName =~ /(set[0-9]*)Map$/) { my $new = $1 . "IMap"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } elsif ($aName =~ /(get[0-9]*)Map$/) { my $new = $1 . "OMap"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } elsif ($aName =~ /(reading[0-9]*)Map$/) { my $new = $1 . "OMap"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } elsif ($aName =~ /^readings(Name|Expr|Regex)(.*)$/) { my $typ = $1; my $sfx = $2; my $num; if (defined($numHash{$sfx})) { $num = $numHash{$sfx}; } else { my $max = 0; foreach my $a (keys %{$attr{$name}}) { if ($a =~ /^reading([0-9]+)\D+$/) { $max = $1 if ($1 > $max); } } $num = sprintf("%02d", $max + 1); $numHash{$sfx} = $num; } my $new = "reading${num}${typ}"; my $val = $attr{$name}{$aName}; CommandAttr(undef, "$name $new $val"); CommandDeleteAttr(undef, "$name $aName"); $dHash{$aName} = 1; Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; } } $dHash{"enableXpath"} = 1; $dHash{"enableXpath-Strict"} = 1; my $ualist = $attr{$name}{userattr}; $ualist = "" if(!$ualist); my %uahash; foreach my $a (split(" ", $ualist)) { if (!$dHash{$a}) { $uahash{$a} = 1; } else { Log3 $name, 3, "$name: dropping $a from userattr list"; } } $attr{$name}{userattr} = join(" ", sort keys %uahash); #Log3 $name, 3, "$name: UpgradeAttribute done, userattr list is $attr{$name}{userattr}"; } ############################################################# # get attribute based specification # for format, map or similar # with generic and absolute default (empty variable num part) # if num is like 1-1 then check for 1 if 1-1 not found sub HTTPMOD_GetFAttr($$$$;$) { my ($name, $prefix, $num, $type, $val) = @_; # first look for attribute with the full num in it if (defined ($attr{$name}{$prefix . $num . $type})) { $val = $attr{$name}{$prefix . $num . $type}; # if not found then check if num contains a subnum # (for regexes with multiple capture groups etc) and look for attribute without this subnum } elsif (($num =~ /^([0-9]+)-[0-9]+$/) && defined ($attr{$name}{$prefix .$1 . $type})) { $val = $attr{$name}{$prefix . $1 . $type}; # if again not found then look for generic attribute without num } elsif (defined ($attr{$name}{$prefix . $type})) { $val = $attr{$name}{$prefix . $type}; } return $val; } ################################################### # checks and stores obfuscated keys like passwords # based on / copied from FRITZBOX_storePassword sub HTTPMOD_StoreKeyValue($$$) { my ($hash, $kName, $value) = @_; my $index = $hash->{TYPE}."_".$hash->{NAME}."_".$kName; my $key = getUniqueId().$index; my $enc = ""; if(eval "use Digest::MD5;1") { $key = Digest::MD5::md5_hex(unpack "H*", $key); $key .= Digest::MD5::md5_hex($key); } for my $char (split //, $value) { my $encode=chop($key); $enc.=sprintf("%.2x",ord($char)^ord($encode)); $key=$encode.$key; } my $err = setKeyValue($index, $enc); return "error while saving the value - $err" if(defined($err)); return undef; } ##################################################### # reads obfuscated value sub HTTPMOD_ReadKeyValue($$) { my ($hash, $kName) = @_; my $name = $hash->{NAME}; my $index = $hash->{TYPE}."_".$hash->{NAME}."_".$kName; my $key = getUniqueId().$index; my ($value, $err); Log3 $name, 5, "$name: ReadKeyValue tries to read value for $kName from file"; ($err, $value) = getKeyValue($index); if ( defined($err) ) { Log3 $name, 4, "$name: ReadKeyValue is unable to read value from file: $err"; return undef; } if ( defined($value) ) { if ( eval "use Digest::MD5;1" ) { $key = Digest::MD5::md5_hex(unpack "H*", $key); $key .= Digest::MD5::md5_hex($key); } my $dec = ''; for my $char (map { pack('C', hex($_)) } ($value =~ /(..)/g)) { my $decode=chop($key); $dec.=chr(ord($char)^ord($decode)); $key=$decode.$key; } return $dec; } else { Log3 $name, 4, "$name: ReadKeyValue could not find key $kName in file"; return undef; } return; } ######################################################################### # replace strings as defined in Attributes for URL, Header and Data # type is request type and can be set01, get03, auth01, update # corresponding context is set, get (or reading, but here we use '' instead) sub HTTPMOD_Replace($$$) { my ($hash, $type, $string) = @_; my $name = $hash->{NAME}; my $context = ""; my $input = $string; if ($type =~ /(auth|set|get)(.*)/) { $context = $1; # context is type without num # for type update there is no num so no individual replacement - only one for the whole update request } #Log3 $name, 4, "$name: Replace called for request type $type"; # Loop through all Replacement Regex attributes foreach my $rr (sort keys %{$attr{$name}}) { 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 = HTTPMOD_GetRegex($name, "replacement", $rNum, "Regex", ""); #my $regex = AttrVal($name, "replacement${rNum}Regex", ""); my $mode = AttrVal($name, "replacement${rNum}Mode", "text"); next if (!$regex); # value can be specific for a get / set / auth step my $value = ""; if ($context && defined ($attr{$name}{"${type}Replacement${rNum}Value"})) { # get / set / auth mit individuellem Replacement für z.B. get01 $value = $attr{$name}{"${type}Replacement${rNum}Value"}; } elsif ($context && defined ($attr{$name}{"${context}Replacement${rNum}Value"})) { # get / set / auth mit generischem Replacement für alle gets / sets $value = $attr{$name}{"${context}Replacement${rNum}Value"}; } elsif (defined ($attr{$name}{"replacement${rNum}Value"})) { # ganz generisches Replacement $value = $attr{$name}{"replacement${rNum}Value"}; } Log3 $name, 5, "$name: Replace called for type $type, regex $regex, mode $mode, " . ($value ? "value $value" : "empty value") . " input: $string"; my $match = 0; if ($mode eq 'text') { $match = ($string =~ s/$regex/$value/g); } elsif ($mode eq 'reading') { my $device = $name; my $reading = $value; if ($value =~ /^([^\:]+):(.+)$/) { $device = $1; $reading = $2; } my $rvalue = ReadingsVal($device, $reading, ""); if ($string =~ s/$regex/$rvalue/g) { Log3 $name, 5, "$name: Replace: reading value is $rvalue"; $match = 1; } } elsif ($mode eq 'internal') { my $device = $name; my $internal = $value; if ($value =~ /^([^\:]+):(.+)$/) { $device = $1; $internal = $2; } my $rvalue = InternalVal($device, $internal, ""); if ($string =~ s/$regex/$rvalue/g) { Log3 $name, 5, "$name: Replace: internal value is $rvalue"; $match = 1; } } elsif ($mode eq 'expression') { my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: Replacement $rNum with expression $value created warning: @_"; }; $match = eval {$string =~ s/$regex/$value/gee}; $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: Replace: invalid regex / expression: /$regex/$value/gee - $@"; } } elsif ($mode eq 'key') { my $rvalue = HTTPMOD_ReadKeyValue($hash, $value); if ($string =~ s/$regex/$rvalue/g) { Log3 $name, 5, "$name: Replace: key $value value is $rvalue"; $match = 1; } } 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; } ######################################################################### sub HTTPMOD_ModifyWithExpr($$$$$) { my ($name, $context, $num, $attr, $text) = @_; my $exp = AttrVal($name, "${context}${num}${attr}", undef); if ($exp) { my $old = $text; my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: ModifyWithExpr ${context}${num}${attr} created warning: @_"; }; $text = eval($exp); $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: error in $attr for $context $num: $@"; } Log3 $name, 5, "$name: $context $num used $attr to convert\n$old\nto\n$text\nusing expr $exp"; } return $text; } ######################################################################### sub HTTPMOD_PrepareRequest($$;$) { my ($hash, $context, $num) = @_; my $name = $hash->{NAME}; my ($url, $header, $data, $exp); $num = 0 if (!$num); # num is not passed wehn called for update request if ($context eq "reading") { # called from GetUpdate - not Get / Set / Auth $url = $hash->{MainURL}; $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/requestHeader/, keys %{$attr{$name}}))); $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/requestData/, keys %{$attr{$name}}))); } else { # called for Get / Set / Auth # hole alle Header bzw. generischen Header ohne Nummer $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}${num}Header/, keys %{$attr{$name}}))); if (length $header == 0) { $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}Header/, keys %{$attr{$name}}))); } if (! HTTPMOD_GetFAttr($name, $context, $num, "NoData")) { # hole Bestandteile der Post data $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}${num}Data/, keys %{$attr{$name}}))); if (length $data == 0) { $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}Data/, keys %{$attr{$name}}))); } } # hole URL $url = HTTPMOD_GetFAttr($name, $context, $num, "URL"); if (!$url) { $url = $hash->{MainURL}; } } $header = HTTPMOD_ModifyWithExpr($name, $context, $num, "HdrExpr", $header); $data = HTTPMOD_ModifyWithExpr($name, $context, $num, "DatExpr", $data); $url = HTTPMOD_ModifyWithExpr($name, $context, $num, "URLExpr", $url); return ($url, $header, $data); } ######################################################################### # create a new authenticated session sub HTTPMOD_Auth($@) { my ($hash, @a) = @_; my $name = $hash->{NAME}; my ($url, $header, $data); # get all steps my %steps; foreach my $attr (keys %{$attr{$name}}) { if ($attr =~ /^sid([0-9]+).+/) { $steps{$1} = 1; } } Log3 $name, 4, "$name: Auth called with Steps: " . join (" ", sort keys %steps); $hash->{sid} = "" if AttrVal($name, "clearSIdBeforeAuth", 0); foreach my $step (sort {$b cmp $a} keys %steps) { # reverse sort ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "sid", $step); if ($url) { my $ignRedir = AttrVal($name, "sid${step}IgnoreRedirects", 0); # add to front of queue (prio) HTTPMOD_AddToQueue($hash, $url, $header, $data, "auth$step", undef, 0, $ignRedir, 1); } else { Log3 $name, 3, "$name: no URL for Auth $step"; } } $hash->{LastAuthTry} = FmtDateTime(gettimeofday()); HTTPMOD_HandleSendQueue("direct:".$name); # AddToQueue with prio did not call this. return; } ######################################## # create hint list for set / get ? sub HTTPMOD_UpdateHintList($) { my ($hash) = @_; my $name = $hash->{NAME}; Log3 $name, 5, "$name: UpdateHintList called"; $hash->{".getList"} = ""; my $fDefault = ($featurelevel > 5.9 ? 1 : 0); if (AttrVal($name, "enableControlSet", $fDefault)) { # spezielle Sets freigeschaltet? $hash->{".setList"} = "interval reread:noArg stop:noArg start:noArg clearCookies:noArg upgradeAttributes:noArg storeKeyValue "; #Log3 $name, 5, "$name: UpdateHintList added control sets"; } else { #Log3 $name, 5, "$name: UpdateHintList ignored control sets ($featurelevel, $fDefault)"; $hash->{".setList"} = ""; } foreach my $aName (keys %{$attr{$name}}) { next if ($aName !~ /^([gs]et)([0-9]+)Name$/); my $context = $1; my $num = $2; my $oName = $attr{$name}{$aName}; my $opt; if ($context eq "set") { my $map = ""; $map = AttrVal($name, "${context}${num}Map", "") if ($context ne "get"); # old Map for set is now IMap (Input) $map = AttrVal($name, "${context}${num}IMap", $map); # new syntax ovverides old one if ($map) { my $hint = HTTPMOD_MapToHint($map); # create hint from map $opt = $oName . ":$hint"; # opt is Name:Hint (from Map) } elsif (AttrVal($name, "${context}${num}NoArg", undef)) { # NoArg explicitely specified for a set? $opt = $oName . ":noArg"; } else { $opt = $oName; # nur den Namen für opt verwenden. } } elsif ($context eq "get") { if (AttrVal($name, "${context}${num}TextArg", undef)) { # TextArg explicitely specified for a get? $opt = $oName; # nur den Namen für opt verwenden. } else { $opt = $oName . ":noArg"; # sonst noArg bei get } } if (AttrVal($name, "${context}${num}Hint", undef)) { # gibt es einen expliziten Hint? $opt = $oName . ":" . AttrVal($name, "${context}${num}Hint", undef); } $hash->{".${context}List"} .= $opt . " "; # save new hint list } delete $hash->{".updateHintList"}; Log3 $name, 5, "$name: UpdateHintList: setlist = " . $hash->{".setList"}; Log3 $name, 5, "$name: UpdateHintList: getlist = " . $hash->{".getList"}; return; } ######################################################## # update hashes to point back from reading name # to attr defining its name and properties # called after Fhem restart or attribute changes # to handle existing readings sub HTTPMOD_UpdateRequestHash($) { my ($hash) = @_; return if (!$hash->{READINGS}); my $name = $hash->{NAME}; my @readingList = sort keys %{$hash->{READINGS}}; my @attrList = sort keys %{$attr{$name}}; Log3 $name, 5, "$name: UpdateRequestHash called"; foreach my $aName (@attrList) { next if ($aName !~ /^(reading|get|set)([0-9]+)(-[0-9]+)?Name$/); my $context = $1; my $num = $2; my $nSubNum = ($3 ? $3 : ""); # named SubReading? my $reqType = ($context eq 'reading' ? 'update' : $context . $num); my $baseReading = $attr{$name}{$aName}; # base reading Name or explicitely named subreading if ($defs{$name}{READINGS}{$baseReading}) { # reading exists Log3 $name, 5, "$name: UpdateRequestHash looks at $baseReading, request $reqType, context $context, num $num, nSubNum $nSubNum"; $hash->{defptr}{readingBase}{$baseReading} = $context; $hash->{defptr}{readingNum}{$baseReading} = $num; $hash->{defptr}{readingSubNum}{$baseReading} = $nSubNum if ($nSubNum); $hash->{defptr}{requestReadings}{$reqType}{$baseReading} = "$context ${num}" . ($nSubNum ? "-$nSubNum" : ""); } # go through the potential subreadings derived from this ..Name attribute with added -Num if (!$nSubNum) { foreach my $reading (@readingList) { next if ($reading !~ /^${baseReading}(-[0-9]+)$/); my $subNum = $1; Log3 $name, 5, "$name: UpdateRequestHash looks at $reading - subNum $subNum"; $hash->{defptr}{readingBase}{$reading} = $context; $hash->{defptr}{readingNum}{$reading} = $num; $hash->{defptr}{readingSubNum}{$reading} = $subNum; $hash->{defptr}{requestReadings}{$reqType}{$reading} = "$context ${num}${subNum}"; # deleteOn ... will later check for e.g. reading02-001DeleteOnError but also for reading02-DeleteOnError (without subNum) } } # special Handling for get / set with CheckAllReadings if ($aName =~ /^(get|set)([0-9]+)Name$/ && HTTPMOD_GetFAttr($name, $context, $num, 'CheckAllReadings')) { foreach my $raName (@attrList) { next if ($aName !~ /^(reading)([0-9]+)(-[0-9]+)?Name$/); my $rbaseReading = $attr{$name}{$raName}; # common base reading Name my $rNum = $2; my $rnSubNum = ($3 ? $3 : ""); # named SubReading? if ($defs{$name}{READINGS}{$rbaseReading}) { # reading exists #$hash->{defptr}{requestReadings}{$reqType}{$rbaseReading} = "$context ${num}" . # ($rnSubNum ? "-$rnSubNum" : ""); # point from reqType get/set and reading Name like "Temp" to the definition in readingXX $hash->{defptr}{requestReadings}{$reqType}{$rbaseReading} = "reading $rNum" . ($rnSubNum ? "-$rnSubNum" : ""); } # go through the potential subreadings - the Name attribute was for a base Reading without explicit subNum if (!$rnSubNum) { foreach my $reading (@readingList) { next if ($reading !~ /^${rbaseReading}(-[0-9]+)$/); #$hash->{defptr}{requestReadings}{$reqType}{$reading} = "$context ${num}$1"; # point from reqType get/set and reading Name like "Temp-001" to the definition in readingXX or even potential readingXX-YYDeleteOnError $hash->{defptr}{requestReadings}{$reqType}{$reading} = "reading ${rNum}$1"; } } } } } delete $hash->{".updateRequestHash"}; return; } ################################################ # SET command - handle predifined control sets sub HTTPMOD_ControlSet($$$) { my ($hash, $setName, $setVal) = @_; my $name = $hash->{NAME}; if ($setName eq 'interval') { if (!$setVal) { Log3 $name, 3, "$name: no interval (sec) specified in set, continuing with $hash->{Interval} (sec)"; return "No Interval specified"; } else { if (int $setVal > 5) { $hash->{Interval} = $setVal; Log3 $name, 3, "$name: timer interval changed to $hash->{Interval} seconds"; HTTPMOD_SetTimer($hash); return "0"; } elsif (int $setVal <= 5) { Log3 $name, 3, "$name: interval $setVal (sec) to small (must be >5), continuing with $hash->{Interval} (sec)"; return "interval too small"; } } } elsif ($setName eq 'reread') { HTTPMOD_GetUpdate("reread:$name"); return "0"; } elsif ($setName eq 'stop') { RemoveInternalTimer("update:$name"); $hash->{TRIGGERTIME} = 0; $hash->{TRIGGERTIME_FMT} = ""; Log3 $name, 3, "$name: internal interval timer stopped"; return "0"; } elsif ($setName eq 'start') { HTTPMOD_SetTimer($hash); return "0"; } elsif ($setName eq 'clearCookies') { delete $hash->{HTTPCookieHash}; return "0"; } elsif ($setName eq 'upgradeAttributes') { HTTPMOD_UpgradeAttributes($hash); return "0"; } elsif ($setName eq 'storeKeyValue') { my $key; if ($setVal =~ /([^ ]+) +(.*)/) { $key = $1; my $err = HTTPMOD_StoreKeyValue($hash, $key, $2); return $err if ($err); } else { return "Please give a key and a value to storeKeyValue"; } return "0"; } return undef; # no control set identified - continue with other sets } ######################################################################### # SET command sub HTTPMOD_Set($@) { my ($hash, @a) = @_; return "\"set HTTPMOD\" needs at least an argument" if (@a < 2); # @a is an array with the command line: DeviceName, setName. Rest is setVal (splitted in fhem.pl by space and tab) my ($name, $setName, @setValArr) = @a; my $setVal = (@setValArr ? join(' ', @setValArr) : ""); my (%rmap, $setNum, $setOpt, $rawVal); Log3 $name, 5, "$name: set called with $setName " . ($setVal ? $setVal : "") if ($setName ne "?"); my $fDefault = ($featurelevel > 5.9 ? 1 : 0); if (AttrVal($name, "enableControlSet", $fDefault)) { # spezielle Sets freigeschaltet? my $error = HTTPMOD_ControlSet($hash, $setName, $setVal); return undef if (defined($error) && $error eq "0"); # control set found and done. return $error if ($error); # error # continue if function returned undef } # Vorbereitung: # suche den übergebenen setName in den Attributen und setze setNum foreach my $aName (keys %{$attr{$name}}) { if ($aName =~ /^set([0-9]+)Name$/) { # ist das Attribut ein "setXName" ? if ($setName eq $attr{$name}{$aName}) { # ist es der im konkreten Set verwendete setName? $setNum = $1; # gefunden -> merke Nummer X im Attribut } } } # gültiger set Aufruf? ($setNum oben schon gesetzt?) if(!defined ($setNum)) { HTTPMOD_UpdateHintList($hash) if ($hash->{".updateHintList"}); #return "Unknown argument $setName, choose one of " . $hash->{".setList"}; if (AttrVal($name, "useSetExtensions", 1)) { #Log3 $name, 5, "$name: set is passing to setExtensions"; return SetExtensions($hash, $hash->{".setList"}, $name, $setName, @setValArr); } else { return "Unknown argument $setName, choose one of " . $hash->{".setList"}; } } Log3 $name, 5, "$name: set found option $setName in attribute set${setNum}Name"; if (AttrVal($name, "disable", undef)) { # check for disabled device Log3 $name, 4, "$name: set called with $setName but device is disabled" if ($setName ne "?"); return undef; } if (!AttrVal($name, "set${setNum}NoArg", undef)) { # soll überhaupt ein Wert übergeben werden? if (!defined($setVal)) { # Ist ein Wert übergeben? Log3 $name, 3, "$name: set without value given for $setName"; return "no value given to set $setName"; } # Eingabevalidierung von Sets mit Definition per Attributen # 1. Schritt, falls definiert, per Umkehrung der Map umwandeln (z.B. Text in numerische Codes) my $map = AttrVal($name, "set${setNum}Map", ""); # old Map for set is now IMap (Input) $map = AttrVal($name, "set${setNum}IMap", $map); # new syntax ovverides old one if ($map) { $rawVal = HTTPMOD_MapConvert ($hash, $map, $setVal, 1); # use reversed map return "set value $setVal did not match defined map" if (!defined($rawVal)); } else { # wenn keine map, dann wenigstens sicherstellen, dass Wert numerisch - falls nicht TextArg. if (!AttrVal($name, "set${setNum}TextArg", undef)) { if ($setVal !~ /^-?\d+\.?\d*$/) { Log3 $name, 3, "$name: set - value $setVal is not numeric"; return "set value $setVal is not numeric"; } } $rawVal = $setVal; } # kein TextArg? if (!AttrVal($name, "set${setNum}TextArg", undef)) { # prüfe Min if (AttrVal($name, "set${setNum}Min", undef)) { my $min = AttrVal($name, "set${setNum}Min", undef); Log3 $name, 5, "$name: is checking value $rawVal against min $min"; return "set value $rawVal is smaller than Min ($min)" if ($rawVal < $min); } # Prüfe Max if (AttrVal($name, "set${setNum}Max", undef)) { my $max = AttrVal($name, "set${setNum}Max", undef); Log3 $name, 5, "$name: set is checking value $rawVal against max $max"; return "set value $rawVal is bigger than Max ($max)" if ($rawVal > $max); } } # Konvertiere input mit IExpr falls definiert my $exp = AttrVal($name, "set${setNum}Expr", ""); # old syntax for input in set $exp = AttrVal($name, "set${setNum}IExpr", ""); # new syntax overrides old one if ($exp) { my $val = $rawVal; my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: Set IExpr $exp created warning: @_"; }; $rawVal = eval($exp); $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: Set error in setExpr $exp: $@"; } else { Log3 $name, 5, "$name: set converted value $val to $rawVal using expr $exp"; } } Log3 $name, 4, "$name: set will now set $setName -> $rawVal"; } else { # NoArg $rawVal = 0; Log3 $name, 4, "$name: set will now set $setName"; } 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, 0, 0, 0, AttrVal($name, "set${setNum}Method", '')); } else { Log3 $name, 3, "$name: no URL for set $setNum"; } return undef; } ######################################################################### # GET command sub HTTPMOD_Get($@) { my ($hash, @a) = @_; return "\"get HTTPMOD\" needs at least an argument" if ( @a < 2 ); # @a is an array with DeviceName, getName, options my ($name, $getName, @getValArr) = @a; my $getVal = (@getValArr ? join(' ', @getValArr) : ""); # optional value after get name - might be used in HTTP request my $getNum; if (AttrVal($name, "disable", undef)) { Log3 $name, 5, "$name: get called with $getName but device is disabled" if ($getName ne "?"); return undef; } Log3 $name, 5, "$name: get called with $getName " if ($getName ne "?"); # Vorbereitung: # suche den übergebenen getName in den Attributen, setze getNum falls gefunden foreach my $aName (keys %{$attr{$name}}) { if ($aName =~ /^get([0-9]+)Name$/) { # ist das Attribut ein "getXName" ? if ($getName eq $attr{$name}{$aName}) { # ist es der im konkreten get verwendete getName? $getNum = $1; # gefunden -> merke Nummer X im Attribut } } } # gültiger get Aufruf? ($getNum oben schon gesetzt?) if(!defined ($getNum)) { HTTPMOD_UpdateHintList($hash) if ($hash->{".updateHintList"}); return "Unknown argument $getName, choose one of " . $hash->{".getList"}; } Log3 $name, 5, "$name: get found option $getName in attribute get${getNum}Name"; Log3 $name, 4, "$name: get will now request $getName" . ($getVal ? ", value = $getVal" : ", no optional value"); my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "get", $getNum); if ($url) { HTTPMOD_Auth $hash if (AttrVal($name, "reAuthAlways", 0)); HTTPMOD_AddToQueue($hash, $url, $header, $data, "get$getNum", $getVal); } else { Log3 $name, 3, "$name: no URL for Get $getNum"; } return "$getName requested, watch readings"; } ################################### # request new data from device # calltype can be update and reread sub HTTPMOD_GetUpdate($) { my ($calltype, $name) = split(':', $_[0]); my $hash = $defs{$name}; my ($url, $header, $data, $count); my $now = gettimeofday(); Log3 $name, 5, "$name: GetUpdate called ($calltype)"; if ($calltype eq "update") { HTTPMOD_SetTimer($hash); } if (AttrVal($name, "disable", undef)) { Log3 $name, 5, "$name: GetUpdate called but device is disabled"; return undef; } if ($hash->{MainURL}) { # queue main get request ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "reading"); # context "reading" is used for other attrs relevant for GetUpdate if ($url) { HTTPMOD_Auth $hash if (AttrVal($name, "reAuthAlways", 0)); HTTPMOD_AddToQueue($hash, $url, $header, $data, "update"); # use request type "update" } else { Log3 $name, 3, "$name: GetUpdate: no Main URL specified"; } } # check if additional readings with individual URLs need to be requested foreach my $getAttr (sort keys %{$attr{$name}}) { next if ($getAttr !~ /^get([0-9]+)Name$/); my $getNum = $1; my $getName = AttrVal($name, $getAttr, ""); next if (!HTTPMOD_GetFAttr($name, 'get', $getNum, "Poll")); Log3 $name, 5, "$name: GetUpdate checks if poll required for $getName ($getNum)"; my $lastPoll = 0; $lastPoll = $hash->{lastpoll}{$getName} if ($hash->{lastpoll} && $hash->{lastpoll}{$getName}); my $dueTime = $lastPoll + HTTPMOD_GetFAttr($name, 'get', $getNum, "PollDelay",0); if ($now >= $dueTime) { Log3 $name, 4, "$name: GetUpdate will request $getName"; $hash->{lastpoll}{$getName} = $now; ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "get", $getNum); if ($url) { HTTPMOD_Auth $hash if (AttrVal($name, "reAuthAlways", 0)); HTTPMOD_AddToQueue($hash, $url, $header, $data, "get$getNum"); } else { Log3 $name, 3, "$name: no URL for Get $getNum"; } } else { Log3 $name, 5, "$name: GetUpdate will skip $getName, delay not over"; } } } ########################################################### # return the name of the caling function for debug output sub HTTPMOD_Caller() { 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 "$subroutine"; } ######################################### # Try to convert a value with a map # called from Set and FormatReading sub HTTPMOD_MapConvert($$$;$) { my ($hash, $map, $val, $reverse) = @_; my $name = $hash->{NAME}; if ($reverse) { $map =~ s/([^, ][^,\$]*):([^,][^,\$]*),? */$2:$1, /g; # reverse map } # spaces in words allowed, separator is ',' or ':' $val = decode ('UTF-8', $val); # convert nbsp from fhemweb $val =~ s/\s| / /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 " . HTTPMOD_Caller() . " converted $val to $newVal with" . ($reverse ? " reversed" : "") . " map $map"; return $newVal; } else { Log3 $name, 3, "$name: MapConvert called from " . HTTPMOD_Caller() . " did not find $val in" . ($reverse ? " reversed" : "") . " map $map"; return undef; } } ######################################### # called from UpdateHintList sub HTTPMOD_MapToHint($) { my ($map) = @_; my $hint = $map; # create hint from map $hint =~ s/([^,\$]+):([^,\$]+)(,?) */$2$3/g; # allow spaces in names $hint =~ s/\s/ /g; # convert spaces for fhemweb return $hint; } ######################################### # Try to call a parse function if defined sub HTTPMOD_TryCall($$$$) { my ($hash, $buffer, $fName, $type) = @_; my $name = $hash->{NAME}; if (AttrVal($name, $fName, undef)) { Log3 $name, 5, "$name: Read is calling $fName for HTTP Response to $type"; my $func = AttrVal($name, 'parseFunction1', undef); no strict "refs"; eval { &{$func}($hash,$buffer) }; if( $@ ) { Log3 $name, 3, "$name: error calling $func: $@"; } use strict "refs"; } } ################################### # recoursive main part for # HTTPMOD_FlattenJSON($$) sub HTTPMOD_JsonFlatter($$;$) { my ($hash,$ref,$prefix) = @_; my $name = $hash->{NAME}; $prefix = "" if( !$prefix ); Log3 $name, 5, "$name: JSON Flatter called : prefix $prefix, ref is $ref"; if (ref($ref) eq "ARRAY" ) { my $key = 0; foreach my $value (@{$ref}) { #Log3 $name, 5, "$name: JSON Flatter in array while, key = $key, value = $value"; if(ref($value) eq "HASH" or ref($value) eq "ARRAY") { Log3 $name, 5, "$name: JSON Flatter doing recursion because value is a " . ref($value); HTTPMOD_JsonFlatter($hash, $value, $prefix.sprintf("%02i",$key+1)."_"); } else { if (defined ($value)) { Log3 $name, 5, "$name: JSON Flatter sets $prefix$key to $value"; $hash->{ParserData}{JSON}{$prefix.$key} = $value; } } $key++; } } elsif (ref($ref) eq "HASH" ) { while( my ($key,$value) = each %{$ref}) { #Log3 $name, 5, "$name: JSON Flatter in hash while, key = $key, value = $value"; if(ref($value) eq "HASH" or ref($value) eq "ARRAY") { Log3 $name, 5, "$name: JSON Flatter doing recursion because value is a " . ref($value); HTTPMOD_JsonFlatter($hash, $value, $prefix.$key."_"); } else { if (defined ($value)) { Log3 $name, 5, "$name: JSON Flatter sets $prefix$key to $value"; $hash->{ParserData}{JSON}{$prefix.$key} = $value; } } } } } #################################### # entry to create a flat hash # out of a pares JSON hash hierarchy sub HTTPMOD_FlattenJSON($$) { my ($hash, $buffer) = @_; my $name = $hash->{NAME}; my $decoded = eval 'decode_json($buffer)'; if ($@) { Log3 $name, 3, "$name: error while parsing JSON data: $@"; } else { HTTPMOD_JsonFlatter($hash, $decoded); Log3 $name, 4, "$name: extracted JSON values to internal"; } } ################################################ # 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); #Log3 $name, 5, "$name: Look for Regex $context$num$type"; # 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 as $val"; } 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 as $val"; } 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($$$$$) { my ($hash, $context, $num, $val, $reading) = @_; my $name = $hash->{NAME}; my ($format, $decode, $encode); my $expr = ""; my $map = ""; if ($context eq "reading") { $expr = AttrVal($name, 'readingsExpr' . $num, "") if ($context ne "set"); # very old syntax, not for set! } $decode = HTTPMOD_GetFAttr($name, $context, $num, "Decode"); $encode = HTTPMOD_GetFAttr($name, $context, $num, "Encode"); $map = HTTPMOD_GetFAttr($name, $context, $num, "Map") if ($context ne "set"); # not for set! $map = HTTPMOD_GetFAttr($name, $context, $num, "OMap", $map); # new syntax $format = HTTPMOD_GetFAttr($name, $context, $num, "Format"); $expr = HTTPMOD_GetFAttr($name, $context, $num, "Expr", $expr) if ($context ne "set"); # not for set! $expr = HTTPMOD_GetFAttr($name, $context, $num, "OExpr", $expr); # new syntax $val = decode($decode, $val) if ($decode); $val = encode($encode, $val) if ($encode); if ($expr) { my $old = $val; # save for later logging my $now = ($hash->{".updateTime"} ? $hash->{".updateTime"} : gettimeofday()); my $timeDiff = 0; # to be available in Exprs my $timeStr = ReadingsTimestamp($name, $reading, 0); $timeDiff = ($now - time_str2num($timeStr)) if ($timeStr); my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: FormatReadig OExpr $expr created warning: @_"; }; $val = eval $expr; $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: FormatReading error, context $context, expression $expr: $@"; } Log3 $name, 5, "$name: FormatReading changed value with Expr $expr from $old to $val"; } if ($map) { # gibt es eine Map? my $nVal = HTTPMOD_MapConvert ($hash, $map, $val); $val = $nVal if (defined($nVal)); } if ($format) { Log3 $name, 5, "$name: FormatReading does sprintf with format " . $format . " value is $val"; $val = sprintf($format, $val); Log3 $name, 5, "$name: FormatReading sprintf result is $val"; } return $val; } ################################### # extract reading for a buffer sub HTTPMOD_ExtractReading($$$$$) { my ($hash, $buffer, $context, $num, $reqType) = @_; # for get / set which use reading.* definitions for parsing reqType might be "get01" and context might be "reading" my $name = $hash->{NAME}; my ($reading, $regex) = ("", "", ""); my ($json, $xpath, $xpathst, $recomb, $regopt, $sublen, $alwaysn); my @subrlist = (); my @matchlist = (); my $try = 1; # was there any applicable parsing definition? $json = HTTPMOD_GetFAttr($name, $context, $num, "JSON"); $xpath = HTTPMOD_GetFAttr($name, $context, $num, "XPath"); $xpathst = HTTPMOD_GetFAttr($name, $context, $num, "XPath-Strict"); $regopt = HTTPMOD_GetFAttr($name, $context, $num, "RegOpt"); $recomb = HTTPMOD_GetFAttr($name, $context, $num, "RecombineExpr"); $sublen = HTTPMOD_GetFAttr($name, $context, $num, "AutoNumLen", 0); $alwaysn = HTTPMOD_GetFAttr($name, $context, $num, "AlwaysNum"); # support for old syntax if ($context eq "reading") { $reading = AttrVal($name, 'readingsName'.$num, ($json ? $json : "reading$num")); $regex = AttrVal($name, 'readingsRegex'.$num, ""); } # new syntax overrides reading and regex $reading = HTTPMOD_GetFAttr($name, $context, $num, "Name", $reading); $regex = HTTPMOD_GetRegex($name, $context, $num, "Regex", $regex); my %namedRegexGroups; if ($regex) { # old syntax for xpath and xpath-strict as prefix in regex - one result joined if (AttrVal($name, "enableXPath", undef) && $regex =~ /^xpath:(.*)/) { $xpath = $1; Log3 $name, 5, "$name: ExtractReading $reading with old XPath syntax in regex /$regex/, xpath = $xpath"; eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); @matchlist = (join ",", @matchlist); # old syntax returns only one value } elsif (AttrVal($name, "enableXPath-Strict", undef) && $regex =~ /^xpath-strict:(.*)/) { $xpathst = $1; Log3 $name, 5, "$name: ExtractReading $reading with old XPath-strict syntax in regex /$regex/..."; my $nodeset; eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; if ($@) { Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; } else { foreach my $node ($nodeset->get_nodelist) { push @matchlist, XML::XPath::XMLParser::as_string($node); } } @matchlist = (join ",", @matchlist); # old syntax returns only one value } else { # normal regex $regopt =~ s/[^gceor]//g if ($regopt); # remove anything but gceor options - rest is already compiled in if ($regopt) { Log3 $name, 5, "$name: ExtractReading $reading with regex /$regex/$regopt ..."; #eval '@matchlist = ($buffer =~ /' . "$regex/$regopt" . ')'; # so geht es nicht bei speziellen Regexes eval "\@matchlist = (\$buffer =~ /\$regex/$regopt)"; Log3 $name, 3, "$name: error in regex matching (with regex option $regopt): $@" if ($@); %namedRegexGroups = %+ if (%+); } else { Log3 $name, 5, "$name: ExtractReading $reading with regex /$regex/..."; @matchlist = ($buffer =~ /$regex/); %namedRegexGroups = %+ if (%+); } Log3 $name, 5, "$name: " . @matchlist . " matches, " . (%namedRegexGroups ? "named capture groups, " : "") . "matchlist = " . join ",", @matchlist if (@matchlist); } } elsif ($json) { Log3 $name, 5, "$name: ExtractReading $reading with json $json ..."; if (defined($hash->{ParserData}{JSON}) && defined($hash->{ParserData}{JSON}{$json})) { @matchlist = ($hash->{ParserData}{JSON}{$json}); } elsif (defined ($hash->{ParserData}{JSON})) { Log3 $name, 5, "$name: ExtractReading $reading with json $json did not match a key directly - trying regex match to create a list"; my @keylist = sort grep /^$json/, keys (%{$hash->{ParserData}{JSON}}); Log3 $name, 5, "$name: ExtractReading $reading with json /^$json/ got keylist @keylist"; @matchlist = map ($hash->{ParserData}{JSON}{$_}, @keylist); } } elsif ($xpath) { Log3 $name, 5, "$name: ExtractReading $reading with XPath $xpath"; eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); } elsif ($xpathst) { Log3 $name, 5, "$name: ExtractReading $reading with XPath-Strict $xpathst"; my $nodeset; eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; if ($@) { Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; } else { # bug in xpath handling reported in https://forum.fhem.de/index.php/topic,45176.315.html #foreach my $node ($nodeset->get_nodelist) { # push @matchlist, XML::XPath::XMLParser::as_string($node); #} if ($nodeset->isa('XML::XPath::NodeSet')) { foreach my $node ($nodeset->get_nodelist) { push @matchlist, XML::XPath::XMLParser::as_string($node); } } else { push @matchlist, $nodeset; } } } else { $try = 0; # neither regex, xpath nor json attribute found ... Log3 $name, 5, "$name: ExtractReading for context $context, num $num - no individual parse definition"; } my $match = @matchlist; if ($match) { if ($recomb) { Log3 $name, 5, "$name: ExtractReading is recombining $match matches with expression $recomb"; my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: RecombineExpr $recomb created warning: @_"; }; my $val = (eval $recomb); $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: ExtractReading error in RecombineExpr: $@"; } Log3 $name, 5, "$name: ExtractReading recombined matchlist to $val"; @matchlist = ($val); $match = 1; } if (%namedRegexGroups) { Log3 $name, 5, "$name: experimental named regex group handling"; foreach my $subReading (keys %namedRegexGroups) { my $val = $namedRegexGroups{$subReading}; push @subrlist, $subReading; # search for group in -Name attrs (-group is sub number) ... my $group = 0; foreach my $aName (sort keys %{$attr{$name}}) { if ($aName =~ /^$context$num-([\d]+)Name$/) { if ($attr{$name}{$context.$num."-".$1."Name"} eq $subReading) { $group = $1; Log3 $name, 5, "$name: ExtractReading uses $context$num-$group attrs for named capture group $subReading"; } } } my $eNum = $num . ($group ? "-".$group : ""); $val = HTTPMOD_FormatReading($hash, $context, $eNum, $val, $subReading); 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 $hash->{defptr}{readingNum}{$subReading} = $num; # used to find maxAge attr $hash->{defptr}{requestReadings}{$reqType}{$subReading} = "$context $eNum"; # used by deleteOnError / deleteIfUnmatched delete $hash->{defptr}{readingOutdated}{$subReading}; # used by MaxAge as well } } else { my $group = 1; foreach my $val (@matchlist) { my ($subNum, $eNum, $subReading); if ($match == 1) { # only one match $eNum = $num; $subReading = ($alwaysn ? "${reading}-" . ($sublen ? sprintf ("%0${sublen}d", 1) : "1") : $reading); } else { # multiple matches -> check for special name of readings $eNum = $num ."-".$group; # don't use GetFAttr here because we don't want to get the value of the generic attribute "Name" # but this name with -group number added as default if (defined ($attr{$name}{$context . $eNum . "Name"})) { $subReading = $attr{$name}{$context . $eNum . "Name"}; } else { if ($sublen) { $subReading = "${reading}-" . sprintf ("%0${sublen}d", $group); } else { $subReading = "${reading}-$group"; } $subNum = "-$group"; } } push @subrlist, $subReading; $val = HTTPMOD_FormatReading($hash, $context, $eNum, $val, $subReading); 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 $hash->{defptr}{readingNum}{$subReading} = $num; # used to find maxAge attr $hash->{defptr}{readingSubNum}{$subReading} = $subNum if ($subNum); # used to find maxAge attr $hash->{defptr}{requestReadings}{$reqType}{$subReading} = "$context $eNum"; # used by deleteOnError / deleteIfUnmathced # might be get01 Temp-02 reading 5 (where its parsing / naming was defined) delete $hash->{defptr}{readingOutdated}{$subReading}; # used by MaxAge as well $group++; } } } else { Log3 $name, 5, "$name: ExtractReading $reading did not match" if ($try); } return ($try, $match, $reading, @subrlist); } ################################### # pull log lines to a file sub HTTPMOD_PullToFile($$$$) { my ($hash, $buffer, $num, $file) = @_; my $name = $hash->{NAME}; my $reading = HTTPMOD_GetFAttr($name, "get", $num, "Name"); 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); my $matches = 0; $hash->{GetSeq} = 0 if (!$hash->{GetSeq}); Log3 $name, 5, "$name: Read is pulling to file, sequence is $hash->{GetSeq}"; while ($buffer =~ /$regex/g) { $matches++; no warnings qw(uninitialized); my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: RecombineExpr $recombine created warning: @_"; }; my $val = eval($recombine); $SIG{__WARN__} = $oldSig; if ($@) { Log3 $name, 3, "$name: PullToFile error in RecombineExpr $recombine: $@"; } else { Log3 $name, 3, "$name: Read pulled line $val"; } } Log3 $name, 3, "$name: Read pulled $matches lines"; if ($matches) { if ($iterate && $hash->{GetSeq} < $iterate) { $hash->{GetSeq}++; Log3 $name, 5, "$name: Read is iterating pull until $iterate, next is $hash->{GetSeq}"; my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "get", $num); HTTPMOD_AddToQueue($hash, $url, $header, $data, "get$num"); } else { Log3 $name, 5, "$name: Read is done with pull after $hash->{GetSeq}."; } } else { Log3 $name, 5, "$name: Read is done with pull, no more lines matched"; } return (1, 1, $reading); } ################################### # delete a reading and its metadata sub HTTPMOD_DeleteReading($$) { my ($hash, $reading) = @_; my $name = $hash->{NAME}; delete($defs{$name}{READINGS}{$reading}); delete $hash->{defptr}{readingOutdated}{$reading}; delete $hash->{defptr}{readingBase}{$reading}; delete $hash->{defptr}{readingNum}{$reading}; delete $hash->{defptr}{readingSubNum}{$reading}; foreach my $rt (keys %{$hash->{defptr}{requestReadings}}) { delete $hash->{defptr}{requestReadings}{$rt}{$reading}; } } ################################### # check max age of all readings sub HTTPMOD_DoMaxAge($) { my ($hash) = @_; my $name = $hash->{NAME}; my ($base, $num, $sub, $max, $rep, $mode, $time, $now); my $readings = $hash->{READINGS}; return if (!$readings); $now = gettimeofday(); HTTPMOD_UpdateRequestHash($hash) if ($hash->{".updateRequestHash"}); foreach my $reading (sort keys %{$readings}) { my $key = $reading; # in most cases the reading name can be looked up in the readingBase hash Log3 $name, 5, "$name: MaxAge: check reading $reading"; if ($hash->{defptr}{readingOutdated}{$reading}) { Log3 $name, 5, "$name: MaxAge: reading $reading was outdated before - skipping"; next; } # get base name of definig attribute like "reading" or "get" $base = $hash->{defptr}{readingBase}{$reading}; if (!$base && $reading =~ /(.*)(-[0-9]+)$/) { # reading name endet auf -Zahl und ist nicht selbst per attr Name definiert # -> suche nach attr Name mit Wert ohne -Zahl $key = $1; $base = $hash->{defptr}{readingBase}{$key}; Log3 $name, 5, "$name: MaxAge: no defptr for this name - reading name seems automatically created with $2 from $key and not updated recently"; } if (!$base) { Log3 $name, 5, "$name: MaxAge: reading $reading doesn't come from a -Name attr -> skipping"; next; } $num = $hash->{defptr}{readingNum}{$key}; if ($hash->{defptr}{readingSubNum}{$key}) { $sub = $hash->{defptr}{readingSubNum}{$key}; } else { $sub = ""; } Log3 $name, 5, "$name: MaxAge: reading definition comes from $base, $num" . ($sub ? ", $sub" : ""); $max = HTTPMOD_GetFAttr($name, $base, $num . $sub, "MaxAge"); if ($max) { $rep = HTTPMOD_GetFAttr($name, $base, $num . $sub, "MaxAgeReplacement", ""); $mode = HTTPMOD_GetFAttr($name, $base, $num . $sub, "MaxAgeReplacementMode", "text"); $time = ReadingsTimestamp($name, $reading, 0); Log3 $name, 5, "$name: MaxAge: max = $max, mode = $mode, rep = $rep"; if ($now - time_str2num($time) > $max) { if ($mode eq "expression") { Log3 $name, 4, "$name: MaxAge: reading $reading too old - using Perl expression as MaxAge replacement: $rep"; my $val = ReadingsVal($name, $reading, ""); my $oldSig = ($SIG{__WARN__} ? $SIG{__WARN__} : 'DEFAULT'); $SIG{__WARN__} = sub { Log3 $name, 3, "$name: MaxAge replacement expr $rep created warning: @_"; }; $rep = eval($rep); $SIG{__WARN__} = $oldSig; if($@) { Log3 $name, 3, "$name: MaxAge: error in replacement expression $1: $@"; $rep = "error in replacement expression"; } else { Log3 $name, 4, "$name: MaxAge: result is $rep"; } readingsBulkUpdate($hash, $reading, $rep); } elsif ($mode eq "text") { Log3 $name, 4, "$name: MaxAge: reading $reading too old - using $rep instead"; readingsBulkUpdate($hash, $reading, $rep); } elsif ($mode eq 'reading') { my $device = $name; my $rname = $rep; if ($rep =~ /^([^\:]+):(.+)$/) { $device = $1; $rname = $2; } my $rvalue = ReadingsVal($device, $rname, ""); Log3 $name, 4, "$name: MaxAge: reading $reading too old - using reading $rname with value $rvalue instead"; readingsBulkUpdate($hash, $reading, $rvalue); } elsif ($mode eq 'internal') { my $device = $name; my $internal = $rep; if ($rep =~ /^([^\:]+):(.+)$/) { $device = $1; $internal = $2; } my $rvalue = InternalVal($device, $internal, ""); Log3 $name, 4, "$name: MaxAge: reading $reading too old - using internal $internal with value $rvalue instead"; readingsBulkUpdate($hash, $reading, $rvalue); } elsif ($mode eq "delete") { Log3 $name, 4, "$name: MaxAge: reading $reading too old - delete it"; HTTPMOD_DeleteReading($hash, $reading); } $hash->{defptr}{readingOutdated}{$reading} = 1 if ($mode ne "delete"); } } else { Log3 $name, 5, "$name: MaxAge: No MaxAge attr for $base, $num, $sub"; } } } ###################################################### # check delete option on error # for readings that were created in the last reqType # e.g. get04 but maybe defined in reading02Regex sub HTTPMOD_DoDeleteOnError($$) { my ($hash, $reqType) = @_; my $name = $hash->{NAME}; return if (!$hash->{READINGS}); HTTPMOD_UpdateRequestHash($hash) if ($hash->{".updateRequestHash"}); if (!$hash->{defptr}{requestReadings} || !$hash->{defptr}{requestReadings}{$reqType}) { Log3 $name, 5, "$name: DoDeleteOnError: no defptr pointing from request to readings - returning"; return; } # readings that were created during last request type reqType (e.g. get03) my $reqReadings = $hash->{defptr}{requestReadings}{$reqType}; foreach my $reading (sort keys %{$reqReadings}) { Log3 $name, 5, "$name: DoDeleteOnError: check reading $reading"; # get parsing / handling definition of this reading (e.g. reading02... or Get04...) my ($context, $eNum) = split (" ", $reqReadings->{$reading}); if (HTTPMOD_GetFAttr($name, $context, $eNum, "DeleteOnError")) { Log3 $name, 4, "$name: DoDeleteOnError: delete reading $reading created by $reqType ($context, $eNum)"; HTTPMOD_DeleteReading($hash, $reading); } } } ################################### # check delete option if unmatched sub HTTPMOD_DoDeleteIfUnmatched($$@) { my ($hash, $reqType, @matched) = @_; my $name = $hash->{NAME}; Log3 $name, 5, "$name: DoDeleteIfUnmatched called with request $reqType"; return if (!$hash->{READINGS}); HTTPMOD_UpdateRequestHash($hash) if ($hash->{".updateRequestHash"}); if (!$hash->{defptr}{requestReadings}) { Log3 $name, 5, "$name: DoDeleteIfUnmatched: no defptr pointing from request to readings - returning"; return; } my %matched; foreach my $m (@matched) { $matched{$m} = 1; } my $reqReadings = $hash->{defptr}{requestReadings}{$reqType}; my @rList = sort keys %{$reqReadings}; Log3 $name, 5, "$name: DoDeleteIfUnmatched: List from requestReadings is @rList"; foreach my $reading (@rList) { Log3 $name, 5, "$name: DoDeleteIfUnmatched: check reading $reading" . ($matched{$reading} ? " (matched)" : " (no match)"); next if ($matched{$reading}); my ($context, $eNum) = split (" ", $reqReadings->{$reading}); Log3 $name, 5, "$name: DoDeleteIfUnmatched: check attr for reading $reading ($context, $eNum)"; if (HTTPMOD_GetFAttr($name, $context, $eNum, "DeleteIfUnmatched")) { Log3 $name, 4, "$name: DoDeleteIfUnmatched: delete reading $reading created by $reqType ($context, $eNum)"; HTTPMOD_DeleteReading($hash, $reading); } else { Log3 $name, 5, "$name: DoDeleteIfUnmatched: no DeleteIfUnmatched for reading $reading ($context, $eNum)"; } } } ########################################### # extract cookies from HTTP Response Header # called from _Read sub HTTPMOD_GetCookies($$) { my ($hash, $header) = @_; my $name = $hash->{NAME}; #Log3 $name, 5, "$name: looking for Cookies in $header"; Log3 $name, 5, "$name: GetCookies is looking for Cookies"; foreach my $cookie ($header =~ m/set-cookie: ?(.*)/gi) { #Log3 $name, 5, "$name: GetCookies found Set-Cookie: $cookie"; $cookie =~ /([^,; ]+)=([^,;\s\v]+)[;,\s\v]*([^\v]*)/; Log3 $name, 4, "$name: GetCookies parsed Cookie: $1 Wert $2 Rest $3"; my $name = $1; my $value = $2; my $rest = ($3 ? $3 : ""); my $path = ""; if ($rest =~ /path=([^;,]+)/) { $path = $1; } my $key = $name . ';' . $path; $hash->{HTTPCookieHash}{$key}{Name} = $name; $hash->{HTTPCookieHash}{$key}{Value} = $value; $hash->{HTTPCookieHash}{$key}{Options} = $rest; $hash->{HTTPCookieHash}{$key}{Path} = $path; } } ################################### # initialize Parsers # called from _Read sub HTTPMOD_InitParsers($$) { my ($hash, $body) = @_; my $name = $hash->{NAME}; # initialize parsers if ($hash->{JSONEnabled} && $body) { HTTPMOD_FlattenJSON($hash, $body); } if ($hash->{XPathEnabled} && $body) { $hash->{ParserData}{XPathTree} = HTML::TreeBuilder::XPath->new; eval {$hash->{ParserData}{XPathTree}->parse($body)}; Log3 $name, ($@ ? 3 : 5), "$name: InitParsers: XPath parsing " . ($@ ? "error: $@" : "done."); } if ($hash->{XPathStrictEnabled} && $body) { eval {$hash->{ParserData}{XPathStrictNodeset} = XML::XPath->new(xml => $body)}; Log3 $name, ($@ ? 3 : 5), "$name: InitParsers: XPath-Strict parsing " . ($@ ? "error: $@" : "done."); } } ################################### # cleanup Parsers # called from _Read sub HTTPMOD_CleanupParsers($) { my ($hash) = @_; my $name = $hash->{NAME}; if ($hash->{XPathEnabled}) { if ($hash->{ParserData}{XPathTree}) { eval {$hash->{ParserData}{XPathTree}->delete()}; Log3 $name, 3, "$name: error deleting XPathTree: $@" if ($@); } } if ($hash->{XPathStrictEnabled}) { if ($hash->{ParserData}{XPathStrictNodeset}) { eval {$hash->{ParserData}{XPathStrictNodeset}->cleanup()}; Log3 $name, 3, "$name: error deleting XPathStrict nodeset: $@" if ($@); } } delete $hash->{ParserData}; } ################################### # Extract SID # called from _Read sub HTTPMOD_ExtractSid($$$$) { my ($hash, $buffer, $context, $num) = @_; my $name = $hash->{NAME}; Log3 $name, 5, "$name: ExtractSid called, context $context, num $num"; #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_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); my @matchlist; if ($json) { Log3 $name, 5, "$name: Checking SID with JSON $json"; if (defined($hash->{ParserData}{JSON}) && defined($hash->{ParserData}{JSON}{$json})) { @matchlist = ($hash->{ParserData}{JSON}{$json}); } } elsif ($xpath) { Log3 $name, 5, "$name: Checking SID with XPath $xpath"; eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); } elsif ($xpathst) { Log3 $name, 5, "$name: Checking SID with XPath-Strict $xpathst"; my $nodeset; eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; if ($@) { Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; } else { foreach my $node ($nodeset->get_nodelist) { push @matchlist, XML::XPath::XMLParser::as_string($node); } } } if (@matchlist) { $buffer = join (' ', @matchlist); if ($regex) { Log3 $name, 5, "$name: ExtractSid is replacing buffer to check with match: $buffer"; } else { $hash->{sid} = $buffer; Log3 $name, 4, "$name: ExtractSid set sid to $hash->{sid}"; return 1; } } if ($regex) { if ($buffer =~ $regex) { $hash->{sid} = $1; Log3 $name, 4, "$name: ExtractSid set sid to $hash->{sid}"; return 1; } else { Log3 $name, 5, "$name: ExtractSid could not match buffer to IdRegex $regex"; } } } ################################### # Check if Auth is necessary # called from _Read sub HTTPMOD_CheckAuth($$$$$) { my ($hash, $buffer, $request, $context, $num) = @_; my $name = $hash->{NAME}; my $doAuth; #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_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); } my @matchlist; if ($json) { Log3 $name, 5, "$name: Checking Auth with JSON $json"; if (defined($hash->{ParserData}{JSON}) && defined($hash->{ParserData}{JSON}{$json})) { @matchlist = ($hash->{ParserData}{JSON}{$json}); } } elsif ($xpath) { Log3 $name, 5, "$name: Checking Auth with XPath $xpath"; eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); } elsif ($xpathst) { Log3 $name, 5, "$name: Checking Auth with XPath-Strict $xpathst"; my $nodeset; eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; if ($@) { Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; } else { foreach my $node ($nodeset->get_nodelist) { push @matchlist, XML::XPath::XMLParser::as_string($node); } } } if (@matchlist) { if ($regex) { $buffer = join (' ', @matchlist); Log3 $name, 5, "$name: CheckAuth is replacing buffer to check with match: $buffer"; } else { Log3 $name, 5, "$name: CheckAuth matched: $buffer"; $doAuth = 1; } } if ($regex) { Log3 $name, 5, "$name: CheckAuth is checking buffer with ReAuthRegex $regex"; $doAuth = 1 if ($buffer =~ $regex); } if ($doAuth) { Log3 $name, 4, "$name: CheckAuth decided new authentication required"; if ($request->{retryCount} < AttrVal($name, "authRetries", 1)) { HTTPMOD_Auth $hash; if (!AttrVal($name, "dontRequeueAfterAuth", 0)) { HTTPMOD_AddToQueue ($hash, $request->{url}, $request->{header}, $request->{data}, $request->{type}, $request->{value}, $request->{retryCount}+1); Log3 $name, 4, "$name: CheckAuth requeued request $request->{type} after auth, retryCount $request->{retryCount} ..."; } return 1; } else { Log3 $name, 4, "$name: Authentication still required but no retries left - did last authentication fail?"; } } else { Log3 $name, 5, "$name: CheckAuth decided no authentication required"; } return 0; } ################################### # update List of Readings to parse # during GetUpdate cycle sub HTTPMOD_UpdateReadingList($) { my ($hash) = @_; my $name = $hash->{NAME}; my %khash; foreach my $a (sort keys %{$attr{$name}}) { if (($a =~ /^readingsName(.*)/) && defined ($attr{$name}{'readingsName' . $1})) { $khash{$1} = 1; # old syntax } elsif ($a =~ /^reading([0-9]+).*/) { $khash{$1} = 1; # new syntax } } my @list = sort keys %khash; $hash->{".readingParseList"} = \@list; Log3 $name, 5, "$name: UpdateReadingList created list of reading.* nums to parse during getUpdate as @list"; delete $hash->{".updateReadingList"}; } ################################### # Check for redirect headers # sub HTTPMOD_CheckRedirects($$) { my ($hash, $header) = @_; my $name = $hash->{NAME}; my $request = $hash->{REQUEST}; my $type = $request->{type}; my $url = $request->{url}; if (!$hash->{httpheader}) { Log3 $name, 4, "$name: no header to look for redirects"; return; } my @header= split("\r\n", $hash->{httpheader}); my @header0= split(" ", shift @header); my $code= $header0[1]; Log3 $name, 4, "$name: checking for redirects, code=$code, ignore=$request->{ignoreredirects}"; if ($code==301 || $code==302 || $code==303) { # redirect ? $hash->{HTTPMOD_Redirects} = 0 if (!$hash->{HTTPMOD_Redirects}); if(++$hash->{HTTPMOD_Redirects} > 5) { Log3 $name, 3, "$name: Too many redirects processing response to $url"; return; } else { my $ra; map { $ra=$1 if($_ =~ m/[Ll]ocation:\s*(\S+)$/) } @header; if (!$ra) { Log3 $name, 3, "$name: Error: got Redirect but no Location-Header from server"; } $ra = "/$ra" if($ra !~ m/^http/ && $ra !~ m/^\//); my $rurl = ($ra =~ m/^http/) ? $ra: $hash->{addr}.$ra; if ($request->{ignoreredirects}) { Log3 $name, 4, "$name: ignoring redirect to $rurl"; 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?? 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; } } else { Log3 $name, 4, "$name: no redirects to handle"; } } ################################### # read / parse new data from device # - callback for non blocking HTTP sub HTTPMOD_Read($$$) { my ($hash, $err, $body) = @_; my $name = $hash->{NAME}; my $request = $hash->{REQUEST}; my $header = ($hash->{httpheader} ? $hash->{httpheader} : ""); my $type = $request->{type}; my ($buffer, $num, $context, $authQueued); my @subrlist = (); # set attribute prefix and num for parsing and formatting depending on request type if ($type =~ /(set|get)(.*)/) { $context = $1; $num = $2; } elsif ($type =~ /(auth)(.*)/) { $context = "sid"; $num = $2; } else { $context = "reading"; $num = ""; } if (!$name || $hash->{TYPE} ne "HTTPMOD") { $name = "HTTPMOD"; Log3 $name, 3, "$name: HTTPMOD _Read callback was called with illegal hash - this should never happen - problem in HttpUtils?"; return undef; } $hash->{BUSY} = 0; 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 ? ", body length " . length($body) : ", no body"); Log3 $name, 5, "$name: Read callback: " . ($body ? "body\r\n$body" : "body empty"); $body = "" if (!$body); 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", ""); # can't precompile a whole substitution so the GetRegex way doesn't work here. # we would need to split the regex into match/replace part and only compile the matching part ... # if a user s affected by Perl's memory he leak he might just add option a to his regex attr #Log3 $name, 5, "$name: Read preProcessRegex is $ppr"; 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: @_"; }; eval $pprexp; $SIG{__WARN__} = $oldSig; $body =~ $ppr; Log3 $name, 5, "$name: Read - body after preProcessRegex: $ppr is $body"; } $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 #delete $hash->{buf} if (AttrVal($name, "removeBuf", 0)); if (AttrVal($name, "showBody", 0)) { $hash->{httpbody} = $body; } $fDefault = ($featurelevel > 5.9 ? 1 : 0); HTTPMOD_InitParsers($hash, $body); HTTPMOD_GetCookies($hash, $header) if (AttrVal($name, "enableCookies", $fDefault)); HTTPMOD_ExtractSid($hash, $buffer, $context, $num); return if (AttrVal($name, "handleRedirects", $fDefault) && HTTPMOD_CheckRedirects($hash, $header)); delete $hash->{HTTPMOD_Redirects}; readingsBeginUpdate($hash); readingsBulkUpdate ($hash, "LAST_ERROR", $err) if ($err && AttrVal($name, "showError", 0)); readingsBulkUpdate($hash, "LAST_REQUEST", $type) if (AttrVal($name, "showMatched", undef)); HTTPMOD_DoMaxAge($hash) if ($hash->{MaxAgeEnabled}); $authQueued = HTTPMOD_CheckAuth($hash, $buffer, $request, $context, $num) if ($context ne "sid"); if ($err || $authQueued || ($context =~ "set|sid" && !HTTPMOD_GetFAttr($name, $context, $num, "ParseResponse"))) { readingsEndUpdate($hash, 1); HTTPMOD_DoDeleteOnError($hash, $type) if ($hash->{DeleteOnError}); HTTPMOD_CleanupParsers($hash); return undef; # don't continue parsing response } my ($checkAll, $tried, $match, $reading); my @unmatched = (); my @matched = (); my $file = HTTPMOD_GetFAttr($name, $context, $num, "PullToFile"); if ($context eq "get" && $file) { ($tried, $match, $reading) = HTTPMOD_PullToFile($hash, $buffer, $num, $file); return undef; } if ($context =~ "get|set") { ($tried, $match, $reading, @subrlist) = HTTPMOD_ExtractReading($hash, $buffer, $context, $num, $type); if ($tried) { if($match) { push @matched, @subrlist; } else { push @unmatched, $reading; } } $checkAll = HTTPMOD_GetFAttr($name, $context, $num, 'CheckAllReadings', !$tried); # if ExtractReading2 could not find any parsing instruction (e.g. regex) then check all Readings } else { $checkAll = 1; } if (AttrVal($name, "extractAllJSON", "") || HTTPMOD_GetFAttr($name, $context, $num, "ExtractAllJSON")) { # create a reading for each JSON object and use formatting options if a correspondig reading name / formatting is defined if ((AttrVal($name, "extractAllJSON", 0) == 2 || HTTPMOD_GetFAttr($name, $context, $num, "ExtractAllJSON", 0) == 2) && ($context =~/get|set/) && (AttrVal($name, "${context}${num}CheckAllReadings", "u") eq "u")) { # ExtractAllJSON mode 2 will create attributes, also CheckAllReadings to 1 for get/set unless already defined as 0 CommandAttr(undef, "$name ${context}${num}CheckAllReadings 1"); } my $rNum = 100; # start value for extractAllJSON mode 2 my $filter = AttrVal($name, "extractAllJSONFilter", ""); if (ref $hash->{ParserData}{JSON} eq "HASH") { foreach my $object (keys %{$hash->{ParserData}{JSON}}) { next if ($filter && $object !~ $filter); my $rName = $object; #my $fDefault = ($featurelevel > 5.9 ? 1 : 0); $rName = makeReadingName($object) if (AttrVal($name, "enforceGoodReadingNames", $fDefault)); if (AttrVal($name, "extractAllJSON", 0) == 2 || (HTTPMOD_GetFAttr($name, $context, $num, "ExtractAllJSON") && HTTPMOD_GetFAttr($name, $context, $num, "ExtractAllJSON") == 2)) { $rName = makeReadingName($object); # at least for this mode! my $existing = 0; # check if there already is an attribute reading[0-9]+JSON $object foreach my $a (grep (/reading[0-9]+JSON/, keys %{$attr{$name}})) { if ($attr{$name}{$a} eq $object) { $existing = $a; } } if ($existing) { Log3 $name, 5, "$name: Read with extractAllJSON mode 2 doesn't set a new attr for $object because $existing already exists with $object"; } else { # find free reading num while (AttrVal($name, "reading${rNum}Name", "u") ne "u" || AttrVal($name, "reading${rNum}JSON", "u") ne "u") { $rNum++; # skip until a number is unused } Log3 $name, 5, "$name: Read with extractAllJSON mode 2 is defining attribute reading${rNum}Name and reading${rNum}JSON for object $object"; CommandAttr(undef, "$name reading${rNum}Name $rName"); CommandAttr(undef, "$name reading${rNum}JSON $object"); } } else { my $value = HTTPMOD_FormatReading($hash, $context, $num, $hash->{ParserData}{JSON}{$object}, $rName); Log3 $name, 5, "$name: Read sets reading $rName to value $value of JSON $object"; readingsBulkUpdate($hash, $rName, $value); push @matched, $rName; # unmatched is not filled for "ExtractAllJSON" delete $hash->{defptr}{readingOutdated}{$rName}; $hash->{defptr}{readingBase}{$rName} = $context; $hash->{defptr}{readingNum}{$rName} = $num; $hash->{defptr}{requestReadings}{$type}{$rName} = "$context $num"; } } if ((AttrVal($name, "extractAllJSON", 0) == 2) && $context eq "reading") { Log3 $name, 5, "$name: Read is done with JSON extractAllJSON mode 2 and now removes this attribute"; CommandDeleteAttr(undef, "$name extractAllJSON"); } elsif ((HTTPMOD_GetFAttr($name, $context, $num, "ExtractAllJSON") && HTTPMOD_GetFAttr($name, $context, $num, "ExtractAllJSON") == 2) && $context =~/get|set/) { Log3 $name, 5, "$name: Read is done with JSON ${context}${num}ExtractAllJSON mode 2 and now removes this attribute"; CommandDeleteAttr(undef, "$name ${context}${num}ExtractAllJSON"); } } else { Log3 $name, 3, "$name: no parsed JSON structure available"; } } HTTPMOD_UpdateReadingList($hash) if ($hash->{".updateReadingList"}); if ($checkAll && defined($hash->{".readingParseList"})) { # check all defined readings and try to extract them Log3 $name, 5, "$name: Read starts parsing response to $type with defined readings: " . join (",", @{$hash->{".readingParseList"}}); foreach $num (@{$hash->{".readingParseList"}}) { # try to parse readings defined in reading.* attributes # pass request $type so we know for later delete (undef, $match, $reading, @subrlist) = HTTPMOD_ExtractReading($hash, $buffer, 'reading', $num, $type); if($match) { push @matched, @subrlist; } else { push @unmatched, $reading; } } } if (AttrVal($name, "showMatched", undef)) { readingsBulkUpdate($hash, "MATCHED_READINGS", join ' ', @matched); readingsBulkUpdate($hash, "UNMATCHED_READINGS", join ' ', @unmatched); } if (!@matched) { Log3 $name, 4, "$name: Read response to $type didn't match any Reading"; } else { 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); readingsEndUpdate($hash, 1); HTTPMOD_TryCall($hash, $buffer, 'parseFunction2', $type); HTTPMOD_DoDeleteIfUnmatched($hash, $type, @matched) if ($hash->{DeleteIfUnmatched}); HTTPMOD_HandleSendQueue("direct:".$name); HTTPMOD_CleanupParsers($hash); return undef; } ####################################### # Aufruf aus InternalTimer mit "queue:$name" # oder direkt mit $direct:$name sub HTTPMOD_HandleSendQueue($) { my (undef,$name) = split(':', $_[0]); my $hash = $defs{$name}; my $queue = $hash->{QUEUE}; my $qlen = ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0); Log3 $name, 5, "$name: HandleSendQueue called, qlen = $qlen"; RemoveInternalTimer ("queue:$name"); if(defined($queue) && @{$queue} > 0) { my $queueDelay = AttrVal($name, "queueDelay", 1); my $now = gettimeofday(); if (!$init_done) { # fhem not initialized, wait with IO InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); Log3 $name, 3, "$name: HandleSendQueue - init not done, delay sending from queue"; return; } if ($hash->{BUSY}) { # still waiting for reply to last request if ($hash->{LASTSEND} && $now > $hash->{LASTSEND} + (AttrVal($name, "timeout", 2)*2) && $now > $hash->{LASTSEND} + 15) { Log3 $name, 5, "$name: HandleSendQueue - still waiting for reply, timeout is over twice - this should never happen"; Log3 $name, 5, "$name: HandleSendQueue - stop waiting"; $hash->{BUSY} = 0; } else { if ($hash->{LASTSEND} && $now > $hash->{LASTSEND} + ($queueDelay * 2)) { $queueDelay *= 2; } InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); Log3 $name, 5, "$name: HandleSendQueue - still waiting for reply to last request, delay sending from queue"; return; } } $hash->{REQUEST} = $queue->[0]; if($hash->{REQUEST}{url} ne "") { # if something to send - check min delay and send my $minSendDelay = AttrVal($hash->{NAME}, "minSendDelay", 0.2); if ($hash->{LASTSEND} && $now < $hash->{LASTSEND} + $minSendDelay) { InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); Log3 $name, 5, "$name: HandleSendQueue - minSendDelay not over, rescheduling"; return; } # set parameters for HttpUtils from request into hash $hash->{BUSY} = 1; # HTTPMOD queue is busy until response is received $hash->{LASTSEND} = $now; # remember when last sent $hash->{redirects} = 0; # for HttpUtils $hash->{callback} = \&HTTPMOD_Read; $hash->{url} = $hash->{REQUEST}{url}; $hash->{header} = $hash->{REQUEST}{header}; $hash->{data} = $hash->{REQUEST}{data}; $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} "; } else { delete $hash->{method}; # make sure this is not set from a prior request } 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 } else { $hash->{ignoreredirects} = $hash->{REQUEST}{ignoreredirects}; # as defined in queue / set when adding to queue } my $sslArgList = AttrVal($name, "sslArgs", undef); if ($sslArgList) { Log3 $name, 5, "$name: sslArgs is set to $sslArgList"; my %sslArgs = split (',', $sslArgList); Log3 $name, 5, "$name: sslArgs hash keys: " . join(",", keys %sslArgs); Log3 $name, 5, "$name: sslArgs hash values: " . join(",", values %sslArgs); $hash->{sslargs} = \%sslArgs; } if (AttrVal($name, "noShutdown", undef)) { $hash->{noshutdown} = 1; } else { delete $hash->{noshutdown}; }; # do user defined replacements first if ($hash->{ReplacementEnabled}) { $hash->{header} = HTTPMOD_Replace($hash, $hash->{REQUEST}{type}, $hash->{header}); $hash->{data} = HTTPMOD_Replace($hash, $hash->{REQUEST}{type}, $hash->{data}); $hash->{url} = HTTPMOD_Replace($hash, $hash->{REQUEST}{type}, $hash->{url}); } # then replace $val in header, data and URL with value from request (setVal) if it is still there $hash->{header} =~ s/\$val/$hash->{value}/g; $hash->{data} =~ s/\$val/$hash->{value}/g; $hash->{url} =~ s/\$val/$hash->{value}/g; # sid replacement is also done here - just before sending so changes in session while request was queued will be reflected if ($hash->{sid}) { $hash->{header} =~ s/\$sid/$hash->{sid}/g; $hash->{data} =~ s/\$sid/$hash->{sid}/g; $hash->{url} =~ s/\$sid/$hash->{sid}/g; } #my $fDefault = ($featurelevel > 5.9 ? 1 : 0); if (AttrVal($name, "enableCookies", $fDefault)) { my $uriPath = ""; if($hash->{url} =~ / ^(http|https):\/\/ # $1: proto (([^:\/]+):([^:\/]+)@)? # $2: auth, $3:user, $4:password ([^:\/]+|\[[0-9a-f:]+\]) # $5: host or IPv6 address (:\d+)? # $6: port (\/.*)$ # $7: path /xi) { $uriPath = $7; } my $cookies = ""; if ($hash->{HTTPCookieHash}) { foreach my $cookie (sort keys %{$hash->{HTTPCookieHash}}) { my $cPath = $hash->{HTTPCookieHash}{$cookie}{Path}; my $idx = index ($uriPath, $cPath); #Log3 $name, 5, "$name: HandleSendQueue checking cookie $hash->{HTTPCookieHash}{$cookie}{Name} path $cPath"; #Log3 $name, 5, "$name: HandleSendQueue cookie path $cPath"; #Log3 $name, 5, "$name: HandleSendQueue URL path $uriPath"; #Log3 $name, 5, "$name: HandleSendQueue no cookie path" if (!$cPath); #Log3 $name, 5, "$name: HandleSendQueue URL path" if (!$uriPath); #Log3 $name, 5, "$name: HandleSendQueue cookie path match idx = $idx"; if (!$uriPath || !$cPath || $idx == 0) { Log3 $name, 5, "$name: HandleSendQueue is using Cookie $hash->{HTTPCookieHash}{$cookie}{Name} " . "with path $hash->{HTTPCookieHash}{$cookie}{Path} and Value " . "$hash->{HTTPCookieHash}{$cookie}{Value} (key $cookie, destination path is $uriPath)"; $cookies .= "; " if ($cookies); $cookies .= $hash->{HTTPCookieHash}{$cookie}{Name} . "=" . $hash->{HTTPCookieHash}{$cookie}{Value}; } else { #Log3 $name, 5, "$name: HandleSendQueue no cookie path match"; Log3 $name, 5, "$name: HandleSendQueue is ignoring Cookie $hash->{HTTPCookieHash}{$cookie}{Name} "; Log3 $name, 5, "$name: " . unpack ('H*', $cPath); Log3 $name, 5, "$name: " . unpack ('H*', $uriPath); } } } if ($cookies) { Log3 $name, 5, "$name: HandleSendQueue is adding Cookie header: $cookies"; $hash->{header} .= "\r\n" if ($hash->{header}); $hash->{header} .= "Cookie: " . $cookies; } } 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"); shift(@{$queue}); # remove first element from queue HttpUtils_NonblockingGet($hash); } else { shift(@{$queue}); # remove invalid first element from queue } if(@{$queue} > 0) { # more items in queue -> schedule next handle InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); } } } ###################################################################################################### # queue requests sub HTTPMOD_AddToQueue($$$$$;$$$$$){ my ($hash, $url, $header, $data, $type, $value, $count, $ignoreredirects, $prio, $method) = @_; my $name = $hash->{NAME}; $value = 0 if (!$value); $count = 0 if (!$count); $ignoreredirects = 0 if (! defined($ignoreredirects)); my %request; $request{url} = $url; $request{header} = $header; $request{data} = $data; $request{type} = $type; $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, 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" . ", initial queue len: $qlen"; if(!$qlen) { $hash->{QUEUE} = [ \%request ]; } else { if ($qlen > AttrVal($name, "queueMax", 20)) { Log3 $name, 3, "$name: AddToQueue - send queue too long ($qlen), dropping request ($type), BUSY = $hash->{BUSY}"; } else { if ($prio) { unshift (@{$hash->{QUEUE}}, \%request); # an den Anfang } else { push(@{$hash->{QUEUE}}, \%request); # ans Ende } } } HTTPMOD_HandleSendQueue("direct:".$name) if (!$prio); # if prio is set, wait until all steps are added to the front - Auth will call HandleSendQueue then. } 1; =pod =item device =item summary retrieves readings from devices with an HTTP Interface =item summary_DE fragt Readings von Geräten mit HTTP-Interface ab =begin html

HTTPMOD

=end html =cut