mirror of
https://github.com/fhem/fhem-mirror.git
synced 2024-11-21 20:49:51 +00:00
6492 lines
170 KiB
Perl
Executable File
6492 lines
170 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
################################################################
|
|
#
|
|
# Copyright notice
|
|
#
|
|
# (c) 2005-2023
|
|
# Copyright: Rudolf Koenig (rudolf dot koenig at fhem dot de)
|
|
# All rights reserved
|
|
#
|
|
# This program free software; you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License V2, which is also
|
|
# distributed together with this program in the file GPL_V2.txt
|
|
#
|
|
# This program 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 V2 for more details.
|
|
#
|
|
# Homepage: http://fhem.de
|
|
#
|
|
# $Id$
|
|
|
|
|
|
use strict;
|
|
use warnings;
|
|
use lib '.';
|
|
use IO::Socket;
|
|
use IO::Socket::INET;
|
|
use Time::HiRes qw(gettimeofday time);
|
|
use Scalar::Util qw(looks_like_number);
|
|
use POSIX;
|
|
use File::Copy qw(copy);
|
|
use Encode;
|
|
|
|
##################################################
|
|
# Forward declarations
|
|
#
|
|
sub AddDuplicate($$);
|
|
sub AnalyzeCommand($$;$);
|
|
sub AnalyzeCommandChain($$;$);
|
|
sub AnalyzeInput($);
|
|
sub AnalyzePerlCommand($$;$);
|
|
sub AssignIoPort($;$);
|
|
sub AttrVal($$$);
|
|
sub AttrNum($$$;$);
|
|
sub Authorized($$$;$);
|
|
sub Authenticate($$);
|
|
sub CallFn(@);
|
|
sub CallInstanceFn(@);
|
|
sub CheckDuplicate($$@);
|
|
sub CheckRegexp($$);
|
|
sub Debug($);
|
|
sub DoSet(@);
|
|
sub Dispatch($$;$$);
|
|
sub DoTrigger($$@);
|
|
sub EvalSpecials($%);
|
|
sub Each($$;$);
|
|
sub FileDelete($);
|
|
sub FileRead($);
|
|
sub FileWrite($@);
|
|
sub FmtDateTime($);
|
|
sub FmtTime($);
|
|
sub GetDefAndAttr($;$);
|
|
sub GetLogLevel(@);
|
|
sub GetTimeSpec($);
|
|
sub GetType($;$);
|
|
sub GlobalAttr($$$$);
|
|
sub HandleArchiving($;$);
|
|
sub HandleTimeout();
|
|
sub IOWrite($@);
|
|
sub InternalTimer($$$;$);
|
|
sub InternalVal($$$);
|
|
sub InternalNum($$$;$);
|
|
sub IsDevice($;$);
|
|
sub IsDisabled($);
|
|
sub IsDummy($);
|
|
sub IsIgnored($);
|
|
sub IsIoDummy($);
|
|
sub IsWe(;$$);
|
|
sub LoadModule($;$);
|
|
sub Log($$);
|
|
sub Log3($$$);
|
|
sub OldTimestamp($);
|
|
sub OldValue($);
|
|
sub OldReadingsAge($$$);
|
|
sub OldReadingsNum($$$;$);
|
|
sub OldReadingsTimestamp($$$);
|
|
sub OldReadingsVal($$$);
|
|
sub OpenLogfile($);
|
|
sub PrintHash($$);
|
|
sub ReadingsAge($$$);
|
|
sub ReadingsNum($$$;$);
|
|
sub ReadingsTimestamp($$$);
|
|
sub ReadingsVal($$$);
|
|
sub RefreshAuthList();
|
|
sub RemoveInternalTimer($;$);
|
|
sub ReplaceEventMap($$$);
|
|
sub ResolveDateWildcards($@);
|
|
sub SecurityCheck();
|
|
sub SemicolonEscape($);
|
|
sub SignalHandling();
|
|
sub TimeNow();
|
|
sub Value($);
|
|
sub WriteStatefile();
|
|
sub XmlEscape($);
|
|
sub addEvent($$;$);
|
|
sub addToDevAttrList($$;$);
|
|
sub applyGlobalAttrFromEnv();
|
|
sub delFromDevAttrList($$);
|
|
sub addToAttrList($;$);
|
|
sub delFromAttrList($);
|
|
sub addToWritebuffer($$@);
|
|
sub attrSplit($);
|
|
sub computeClientArray($$);
|
|
sub concatc($$$);
|
|
sub configDBUsed();
|
|
sub createNtfyHash();
|
|
sub createUniqueId();
|
|
sub devspec2array($;$$);
|
|
sub doGlobalDef($);
|
|
sub escapeLogLine($);
|
|
sub evalStateFormat($);
|
|
sub execFhemTestFile();
|
|
sub fhem($@);
|
|
sub fhemTimeGm($$$$$$);
|
|
sub fhemTimeLocal($$$$$$);
|
|
sub fhemTzOffset($);
|
|
sub getAllAttr($;$$);
|
|
sub getAllGets($;$);
|
|
sub getAllSets($;$);
|
|
sub getPawList($);
|
|
sub getUniqueId();
|
|
sub hashKeyRename($$$);
|
|
sub json2nameValue($;$$$$);
|
|
sub json2reading($$;$$$$);
|
|
sub latin1ToUtf8($);
|
|
sub myrename($$$);
|
|
sub notifyRegexpChanged($$;$);
|
|
sub parseParams($;$$$);
|
|
sub prepareFhemTestFile();
|
|
sub perlSyntaxCheck($%);
|
|
sub readingsBeginUpdate($);
|
|
sub readingsBulkUpdate($$$@);
|
|
sub readingsEndUpdate($$);
|
|
sub readingsSingleUpdate($$$$;$);
|
|
sub readingsDelete($$);
|
|
sub redirectStdinStdErr();
|
|
sub rejectDuplicate($$$);
|
|
sub resolveAttrRename($$);
|
|
sub restoreDir_init(;$);
|
|
sub restoreDir_rmTree($);
|
|
sub restoreDir_saveFile($$);
|
|
sub restoreDir_mkDir($$$);
|
|
sub setGlobalAttrBeforeFork($);
|
|
sub setReadingsVal($$$$);
|
|
sub setAttrList($$);
|
|
sub setDevAttrList($;$);
|
|
sub setDisableNotifyFn($$);
|
|
sub setNotifyDev($$);
|
|
sub toJSON($);
|
|
sub utf8ToLatin1($);
|
|
|
|
sub CommandAttr($$);
|
|
sub CommandCancel($$);
|
|
sub CommandDefaultAttr($$);
|
|
sub CommandDefine($$);
|
|
sub CommandDefMod($$);
|
|
sub CommandDelete($$);
|
|
sub CommandDeleteAttr($$);
|
|
sub CommandDeleteReading($$);
|
|
sub CommandDisplayAttr($$);
|
|
sub CommandGet($$);
|
|
sub CommandIOWrite($$);
|
|
sub CommandInclude($$);
|
|
sub CommandList($$);
|
|
sub CommandModify($$);
|
|
sub CommandQuit($$);
|
|
sub CommandReload($$;$);
|
|
sub CommandRename($$);
|
|
sub CommandRereadCfg($$);
|
|
sub CommandSave($$);
|
|
sub CommandSet($$);
|
|
sub CommandSetReading($$);
|
|
sub CommandSetstate($$);
|
|
sub CommandSetuuid($$);
|
|
sub CommandShutdown($$;$$$);
|
|
sub CommandSleep($$);
|
|
sub CommandTrigger($$);
|
|
|
|
# configDB special
|
|
sub cfgDB_Init;
|
|
sub cfgDB_ReadAll;
|
|
sub cfgDB_SaveState;
|
|
sub cfgDB_SaveCfg;
|
|
sub cfgDB_AttrRead;
|
|
sub cfgDB_FileRead;
|
|
sub cfgDB_FileUpdate;
|
|
sub cfgDB_FileWrite;
|
|
|
|
##################################################
|
|
# Variables:
|
|
# global, to be able to access them from modules
|
|
|
|
#Special values in %modules (used if set):
|
|
# AttrFn - called for attribute changes
|
|
# DefFn - define a "device" of this type
|
|
# DeleteFn - clean up (delete logfile), called by delete after UndefFn
|
|
# ExceptFn - called if the global select reports an except field
|
|
# FingerprintFn - convert messages for duplicate detection
|
|
# GetFn - get some data from this device
|
|
# NotifyFn - call this if some device changed its properties
|
|
# ParseFn - Interpret a raw message
|
|
# ReadFn - Reading from a Device (see FHZ/WS300)
|
|
# ReadyFn - check for available data, if no FD
|
|
# RenameFn - inform the device about its renaming
|
|
# SetFn - set/activate this device
|
|
# DelayedShutdownFn - used to delay shutdown for some seconds
|
|
# ShutdownFn-called before shutdown, if DelayedShutdownFn is "over"
|
|
# StateFn - set local info for this device, do not activate anything
|
|
# UndefFn - clean up (delete timer, close fd), called by delete and rereadcfg
|
|
# prioSave - save the definition at the start, for a small SubProcess
|
|
|
|
#Special values in %defs:
|
|
# TYPE - The name of the module it belongs to
|
|
# STATE - Oneliner describing its state
|
|
# NR - its "serial" number
|
|
# DEF - its definition
|
|
# READINGS- The readings. Each value has a "VAL" and a "TIME" component.
|
|
# FD - FileDescriptor. Used by selectlist / readyfnlist
|
|
# IODev - attached to io device
|
|
# CHANGED - Currently changed attributes of this device. Used by NotifyFn
|
|
# VOLATILE- Set if the definition should be saved to the "statefile"
|
|
# NOTIFYDEV - if set, the NotifyFn will only be called for this device
|
|
|
|
use vars qw($addTimerStacktrace);# set to 1 by fhemdebug
|
|
use vars qw($auth_refresh);
|
|
use vars qw($cmdFromAnalyze); # used by the warnings-sub
|
|
use vars qw($devcount); # Maximum device number, used for storing.
|
|
use vars qw($devcountPrioSave); # Maximum prioSave device number
|
|
use vars qw($devcountTemp); # number for temp devices like client connect
|
|
use vars qw($unicodeEncoding); # internal encoding is unicode (wide character)
|
|
use vars qw($featurelevel);
|
|
use vars qw($fhemForked); # 1 in a fhemFork()'ed process, else undef
|
|
use vars qw($fhemTestFile); # file to include if -t is specified
|
|
use vars qw($fhem_started); # used for uptime calculation
|
|
use vars qw($haveInet6); # Using INET6
|
|
use vars qw($init_done); #
|
|
use vars qw($internal_data); # FileLog/DbLog -> SVG data transport
|
|
use vars qw($lastDefChange); # number of last def/attr change
|
|
use vars qw($lastWarningMsg); # set by the warnings-sub
|
|
use vars qw($nextat); # Time when next timer will be triggered.
|
|
use vars qw($numCPUs); # Number of CPUs on Linux, else 1
|
|
use vars qw($reread_active);
|
|
use vars qw($selectTimestamp); # used to check last select exit timestamp
|
|
use vars qw($tmpdevcount); # Maximum device number, used for storing
|
|
use vars qw($winService); # the Windows Service object
|
|
|
|
use vars qw(%attr); # Attributes
|
|
use vars qw(%cmds); # Global command name hash.
|
|
use vars qw(%data); # Hash for user data
|
|
use vars qw(%defaultattr); # Default attributes, used by FHEM2FHEM
|
|
use vars qw(%defs); # FHEM device/button definitions
|
|
use vars qw(%inform); # Used by telnet_ActivateInform
|
|
use vars qw(%intAt); # Internal timer hash, used by apptime
|
|
use vars qw(%logInform); # Used by FHEMWEB/Event-Monitor
|
|
use vars qw(%modules); # List of loaded modules (device/log/etc)
|
|
use vars qw(%ntfyHash); # hash of devices needed to be notified.
|
|
use vars qw(%prioQueues); #
|
|
use vars qw(%readyfnlist); # devices which want a "readyfn"
|
|
use vars qw(%selectlist); # devices which want a "select"
|
|
use vars qw(%value); # Current values, see commandref.html
|
|
|
|
use vars qw(@intAtA); # Internal timer array
|
|
use vars qw(@structChangeHist); # Contains the last 10 structural changes
|
|
|
|
use constant {
|
|
DAYSECONDS => 86400,
|
|
HOURSECONDS => 3600,
|
|
MINUTESECONDS => 60
|
|
};
|
|
|
|
$selectTimestamp = gettimeofday();
|
|
my $cvsid = '$Id$';
|
|
|
|
my $AttrList = "alias comment:textField-long eventMap:textField-long ".
|
|
"group room suppressReading userattr ".
|
|
"userReadings:textField-long verbose:0,1,2,3,4,5 ";
|
|
|
|
my @authenticate; # List of authentication devices
|
|
my @authorize; # List of authorization devices
|
|
my $currcfgfile=""; # current config/include file
|
|
my $currlogfile; # logfile, without wildcards
|
|
my $duplidx=0; # helper for the above pool
|
|
my $evalSpecials; # Used by EvalSpecials->AnalyzeCommand
|
|
my $intAtCnt=0;
|
|
my $logopened = 0; # logfile opened or using stdout
|
|
my $namedef = "where <name> is a single device name, a list separated by comma (,) or a regexp. See the devspec section in the commandref.html for details.\n";
|
|
my $rcvdquit; # Used for quit handling in init files
|
|
my $readingsUpdateDelayTrigger; # needed internally
|
|
my $gotSig; # non-undef if got a signal
|
|
my %oldvalue; # Old values, see commandref.html
|
|
my $wbName = ".WRITEBUFFER"; # Buffer-name for delayed writing via select
|
|
my %comments; # Comments from the include files
|
|
my %duplicate; # Pool of received msg for multi-fhz/cul setups
|
|
my @cmdList; # Remaining commands in a chain. Used by sleep
|
|
my %sleepers; # list of sleepers
|
|
my %delayedShutdowns; # definitions needing delayed shutdown
|
|
my %fuuidHash; # for duplicate checking
|
|
my $globalUniqueID; # cache it
|
|
my $LOG; # Log file handle, formerly LOG
|
|
|
|
my $readytimeout = ($^O eq "MSWin32") ? 0.1 : 5.0;
|
|
|
|
$init_done = 0;
|
|
$lastDefChange = 0;
|
|
$featurelevel = 6.3; # see also GlobalAttr
|
|
$numCPUs = `grep -c ^processor /proc/cpuinfo 2>&1` if($^O eq "linux");
|
|
$numCPUs = ($numCPUs && $numCPUs =~ m/(\d+)/ ? $1 : 1);
|
|
|
|
|
|
$modules{Global}{ORDER} = -1;
|
|
$modules{Global}{LOADED} = 1;
|
|
no warnings 'qw';
|
|
my @globalAttrList = qw(
|
|
altitude
|
|
apiversion
|
|
archivecmd
|
|
archivedir
|
|
archivesort:timestamp,alphanum
|
|
archiveCompress
|
|
autoload_undefined_devices:0,1
|
|
autosave:1,0
|
|
backup_before_update
|
|
backupcmd
|
|
backupdir
|
|
backupsymlink
|
|
blockingCallMax
|
|
commandref:modular,full
|
|
configfile
|
|
disableFeatures:multiple-strict,attrTemplate,securityCheck,saveuuid
|
|
dnsHostsFile
|
|
dnsServer
|
|
dupTimeout
|
|
exclude_from_update
|
|
encoding:bytestream,unicode
|
|
hideExcludedUpdates:1,0
|
|
featurelevel:6.1,6.0,5.9,5.8,5.7,5.6,5.5,99.99
|
|
genericDisplayType:switch,outlet,light,blind,speaker,thermostat
|
|
holiday2we
|
|
httpcompress:0,1
|
|
ignoreRegexp
|
|
keyFileName
|
|
language:EN,DE
|
|
lastinclude
|
|
latitude
|
|
logdir
|
|
logfile
|
|
longitude
|
|
maxChangeLog
|
|
maxShutdownDelay
|
|
modpath
|
|
motd
|
|
mseclog:1,0
|
|
nofork:1,0
|
|
nrarchive
|
|
perlSyntaxCheck:0,1
|
|
pidfilename
|
|
proxy
|
|
proxyAuth
|
|
proxyExclude
|
|
restartDelay
|
|
restoreDirs
|
|
sendStatistics:onUpdate,manually,never
|
|
showInternalValues:1,0
|
|
sslVersion
|
|
stacktrace:1,0
|
|
statefile
|
|
title
|
|
updateInBackground:1,0
|
|
updateNoFileCheck:1,0
|
|
useInet6:1,0
|
|
version
|
|
);
|
|
use warnings 'qw';
|
|
$modules{Global}{AttrList} = join(" ", @globalAttrList);
|
|
$modules{Global}{AttrFn} = "GlobalAttr";
|
|
|
|
use vars qw($readingFnAttributes);
|
|
no warnings 'qw';
|
|
my @attrList = qw(
|
|
event-aggregator
|
|
event-min-interval
|
|
event-on-change-reading
|
|
event-on-update-reading
|
|
oldreadings
|
|
stateFormat:textField-long
|
|
timestamp-on-change-reading
|
|
);
|
|
$readingFnAttributes = join(" ", @attrList);
|
|
my %attrSource = map { s/:.*//; $_ => "framework" } @attrList;
|
|
map { $attrSource{$_} = "framework" } qw(
|
|
ignore
|
|
disable
|
|
disabledForIntervals
|
|
);
|
|
|
|
my %ra = (
|
|
"suppressReading" => { s=>"\n" },
|
|
"event-aggregator" => { s=>",", c=>".attraggr" },
|
|
"event-on-update-reading" => { s=>",", c=>".attreour" },
|
|
"event-on-change-reading" => { s=>",", c=>".attreocr", r=>":.*" },
|
|
"timestamp-on-change-reading"=> { s=>",", c=>".attrtocr" },
|
|
"event-min-interval" => { s=>",", c=>".attrminint", r=>":.*",
|
|
isNum=>1 },
|
|
"oldreadings" => { s=>",", c=>".or" },
|
|
"devStateIcon" => { s=>" ", r=>":.*", p=>"^{.*}\$",
|
|
pv=>{"%name"=>1, "%state"=>1, "%type"=>1} },
|
|
);
|
|
|
|
%cmds = (
|
|
"?" => { ReplacedBy => "help" },
|
|
"attr" => { Fn=>"CommandAttr",
|
|
Hlp=>"[-a] [-r] [-silent] <devspec> <attrname> [<attrval>],".
|
|
"set attribute for <devspec>"},
|
|
"cancel" => { Fn=>"CommandCancel",
|
|
Hlp=>"[<id> [quiet]],list sleepers, cancel sleeper with <id>" },
|
|
"createlog"=> { ModuleName => "autocreate" },
|
|
"define" => { Fn=>"CommandDefine",
|
|
Hlp=>"[option] <name> <type> <options>,define a device" },
|
|
"defmod" => { Fn=>"CommandDefMod",
|
|
Hlp=>"[-temporary] <name> <type> <options>,".
|
|
"define or modify a device" },
|
|
"deleteattr" => { Fn=>"CommandDeleteAttr",
|
|
Hlp=>"[-silent] <devspec> [<attrname>],delete attribute for <devspec>" },
|
|
"deletereading" => { Fn=>"CommandDeleteReading",
|
|
Hlp=>"<devspec> <readingname> [older-than-seconds],".
|
|
"delete user defined readings" },
|
|
"delete" => { Fn=>"CommandDelete",
|
|
Hlp=>"<devspec>,delete the corresponding definition(s)"},
|
|
"displayattr"=> { Fn=>"CommandDisplayAttr",
|
|
Hlp=>"<devspec> [attrname],display attributes" },
|
|
"get" => { Fn=>"CommandGet",
|
|
Hlp=>"<devspec> <type-specific>,request data from <devspec>" },
|
|
"include" => { Fn=>"CommandInclude",
|
|
Hlp=>"<filename>,read the commands from <filename>" },
|
|
"iowrite" => { Fn=>"CommandIOWrite",
|
|
Hlp=>"<iodev> <data>,write raw data with iodev" },
|
|
"list" => { Fn=>"CommandList",
|
|
Hlp=>"[-r] [devspec] [value],list definitions and status info" },
|
|
"modify" => { Fn=>"CommandModify",
|
|
Hlp=>"device <type-dependent-options>,modify the definition" },
|
|
"quit" => { Fn=>"CommandQuit",
|
|
ClientFilter => "telnet",
|
|
Hlp=>",end the client session" },
|
|
"exit" => { Fn=>"CommandQuit",
|
|
ClientFilter => "telnet",
|
|
Hlp=>",end the client session" },
|
|
"reload" => { Fn=>"CommandReload",
|
|
Hlp=>"<module>,reload the given module (e.g. 99_PRIV)" },
|
|
"rename" => { Fn=>"CommandRename",
|
|
Hlp=>"<old> <new>,rename a definition" },
|
|
"rereadcfg" => { Fn=>"CommandRereadCfg",
|
|
Hlp=>"[configfile],read in the config after deleting everything" },
|
|
"restore" => {
|
|
Hlp=>"[list] [<filename|directory>],restore files saved by update"},
|
|
"save" => { Fn=>"CommandSave",
|
|
Hlp=>"[configfile],write the configfile and the statefile" },
|
|
"set" => { Fn=>"CommandSet",
|
|
Hlp=>"<devspec> <type-specific>,transmit code for <devspec>" },
|
|
"setreading" => { Fn=>"CommandSetReading",
|
|
Hlp=>"<devspec> [YYYY-MM-DD HH:MM:SS] <reading> <value>,".
|
|
"set reading for <devspec>" },
|
|
"setstate"=> { Fn=>"CommandSetstate",
|
|
Hlp=>"<devspec> <state>,set the state shown in the command list" },
|
|
"setuuid" => { Fn=>"CommandSetuuid", Hlp=>"" },
|
|
"setdefaultattr" => { Fn=>"CommandDefaultAttr",
|
|
Hlp=>"[<attrname> [<attrvalue>]],".
|
|
"set attr for following definitions" },
|
|
"shutdown"=> { Fn=>"CommandShutdown",
|
|
Hlp=>"[restart|exitValue],terminate the server" },
|
|
"sleep" => { Fn=>"CommandSleep",
|
|
Hlp=>"<sec|timespec|regex> [<id>] [quiet],".
|
|
"sleep for sec, 3 decimal places" },
|
|
"trigger" => { Fn=>"CommandTrigger",
|
|
Hlp=>"<devspec> <state>,trigger notify command" },
|
|
"update" => {
|
|
Hlp => "[<fileName>|all|check|checktime|force] ".
|
|
"[http://.../controlfile],update FHEM" },
|
|
"updatefhem" => { ReplacedBy => "update" },
|
|
"usb" => { ModuleName => "autocreate" }
|
|
);
|
|
|
|
###################################################
|
|
# Start the program
|
|
my $fhemdebug;
|
|
$fhemdebug = shift @ARGV if($ARGV[0] && $ARGV[0] eq "-d");
|
|
prepareFhemTestFile();
|
|
|
|
if(int(@ARGV) < 1) {
|
|
print "Usage:\n";
|
|
print "as server: perl fhem.pl [-d] {<configfile>|configDB}\n";
|
|
print "as client: perl fhem.pl [host:]port cmd cmd cmd...\n";
|
|
print "testing: perl fhem.pl -t <testfile>.t\n";
|
|
if($^O =~ m/Win/) {
|
|
print "install as windows service: perl fhem.pl configfile -i\n";
|
|
print "uninstall the windows service: perl fhem.pl -u\n";
|
|
}
|
|
exit(1);
|
|
}
|
|
|
|
# If started as root, and there is a fhem user in the /etc/passwd, su to it
|
|
if($^O !~ m/Win/ && $< == 0) {
|
|
|
|
my @pw = getpwnam("fhem");
|
|
if(@pw) {
|
|
use POSIX qw(setuid setgid);
|
|
|
|
# set primary group
|
|
setgid($pw[3]);
|
|
|
|
# read all secondary groups into an array:
|
|
my @groups;
|
|
while ( my ($name, $pw, $gid, $members) = getgrent() ) {
|
|
push(@groups, $gid) if ( grep($_ eq $pw[0],split(/\s+/,$members)) );
|
|
}
|
|
|
|
# set the secondary groups via $)
|
|
if (@groups) {
|
|
$) = "$pw[3] ".join(" ",@groups);
|
|
} else {
|
|
$) = "$pw[3] $pw[3]";
|
|
}
|
|
|
|
setuid($pw[2]);
|
|
}
|
|
|
|
}
|
|
|
|
###################################################
|
|
# Client code
|
|
if(int(@ARGV) > 1 && $ARGV[$#ARGV] ne "-i") {
|
|
my $buf;
|
|
my $addr = shift @ARGV;
|
|
$addr = "localhost:$addr" if($addr !~ m/:/);
|
|
my $client = IO::Socket::INET->new(PeerAddr => $addr);
|
|
die "Can't connect to $addr\n" if(!$client);
|
|
for(my $i=0; $i < int(@ARGV); $i++) {
|
|
syswrite($client, $ARGV[$i]."\n");
|
|
}
|
|
shutdown($client, 1);
|
|
alarm(30); #117226
|
|
while(sysread($client, $buf, 256) > 0) {
|
|
$buf =~ s/\xff\xfb\x01Password: //;
|
|
$buf =~ s/\xff\xfc\x01\r\n//;
|
|
$buf =~ s/\xff\xfd\x00//;
|
|
print($buf);
|
|
}
|
|
exit(0);
|
|
}
|
|
# End of client code
|
|
###################################################
|
|
|
|
|
|
SignalHandling();
|
|
|
|
###################################################
|
|
# Windows Service Support: install/remove or start the fhem service
|
|
if($^O =~ m/Win/) {
|
|
(my $dir = $0) =~ s+[/\\][^/\\]*$++; # Find the FHEM directory
|
|
chdir($dir);
|
|
$winService = eval {require FHEM::WinService; FHEM::WinService->new(\@ARGV);};
|
|
if((!$winService || $@) && ($ARGV[$#ARGV] eq "-i" || $ARGV[$#ARGV] eq "-u")) {
|
|
print "Cannot initialize FHEM::WinService: $@, exiting.\n";
|
|
exit 0;
|
|
}
|
|
}
|
|
$winService ||= {};
|
|
|
|
###################################################
|
|
# Server initialization
|
|
doGlobalDef($ARGV[0]);
|
|
|
|
if(configDBUsed()) {
|
|
eval "use configDB";
|
|
Log 1, $@ if($@);
|
|
cfgDB_Init();
|
|
}
|
|
|
|
|
|
# As newer Linux versions reset serial parameters after fork, we parse the
|
|
# config file after the fork. But we need some global attr parameters before,
|
|
# so we read them here. FHEM_GLOBALATTR is for docker, as it needs to overwrite
|
|
# fhem.cfg
|
|
my (undef, $globalAttrFromEnv) = parseParams($ENV{FHEM_GLOBALATTR});
|
|
setGlobalAttrBeforeFork($attr{global}{configfile});
|
|
applyGlobalAttrFromEnv();
|
|
|
|
Log 1, $_ for eval{@{$winService->{ServiceLog}};};
|
|
|
|
# Go to background if the logfile is a real file (not stdout)
|
|
if($^O =~ m/Win/ && !$attr{global}{nofork}) {
|
|
$attr{global}{nofork}=1;
|
|
}
|
|
if($attr{global}{logfile} ne "-" && !$attr{global}{nofork}) {
|
|
defined(my $pid = fork) || die "Can't fork: $!";
|
|
exit(0) if $pid;
|
|
}
|
|
|
|
# FritzBox special: Wait until the time is set via NTP,
|
|
# but not more than 2 hours
|
|
if(gettimeofday() < 2*3600) {
|
|
Log 1, "date/time not set, waiting up to 2 hours to be set.";
|
|
while(gettimeofday() < 2*3600) {
|
|
sleep(5);
|
|
}
|
|
}
|
|
|
|
###################################################
|
|
# initialize the readings semantics meta information
|
|
require RTypes;
|
|
RTypes_Initialize();
|
|
|
|
$defs{global}{init_errors}="";
|
|
if(configDBUsed()) {
|
|
my $ret = cfgDB_ReadAll(undef);
|
|
$defs{global}{init_errors} .= "configDB: $ret\n" if($ret);
|
|
|
|
} else {
|
|
my $ret = CommandInclude(undef, $attr{global}{configfile});
|
|
$defs{global}{init_errors} .= "configfile: $ret\n" if($ret);
|
|
|
|
my $stateFile = $attr{global}{statefile};
|
|
if($stateFile) {
|
|
my @t = localtime(gettimeofday());
|
|
$stateFile = ResolveDateWildcards($stateFile, @t);
|
|
if(-r $stateFile) {
|
|
$ret = CommandInclude(undef, $stateFile);
|
|
$defs{global}{init_errors} .= "$stateFile: $ret\n" if($ret);
|
|
}
|
|
}
|
|
}
|
|
applyGlobalAttrFromEnv();
|
|
|
|
my $pfn = $attr{global}{pidfilename};
|
|
if($pfn) {
|
|
die "$pfn: $!\n" if(!open(PID, ">$pfn"));
|
|
print PID $$ . "\n";
|
|
close(PID);
|
|
}
|
|
|
|
$init_done = 1;
|
|
$lastDefChange = 1;
|
|
|
|
sub
|
|
finish_init()
|
|
{
|
|
foreach my $d (keys %defs) {
|
|
my $hash = $defs{$d};
|
|
if($hash->{IODevMissing}) {
|
|
if($hash->{IODevName} && $defs{$hash->{IODevName}}) {
|
|
fhem_setIoDev($hash, $hash->{IODevName});
|
|
} else {
|
|
AssignIoPort($hash); # For fhem.cfg editors?
|
|
}
|
|
delete $hash->{IODevMissing};
|
|
delete $hash->{IODevName};
|
|
}
|
|
}
|
|
|
|
my $init_errors_first = ($defs{global}{init_errors} ? 1 : 0);
|
|
SecurityCheck();
|
|
if($defs{global}{init_errors}) {
|
|
$attr{global}{autosave} = 0 if($init_errors_first);
|
|
$defs{global}{init_errors} =
|
|
"Messages collected while initializing FHEM:".
|
|
"$defs{global}{init_errors}\n".
|
|
($init_errors_first ? "Autosave deactivated" : "");
|
|
Log 1, $defs{global}{init_errors}
|
|
if(AttrVal("global","motd","") ne "none");
|
|
}
|
|
|
|
}
|
|
finish_init();
|
|
|
|
|
|
$fhem_started = int(gettimeofday());
|
|
DoTrigger("global", "INITIALIZED", 1);
|
|
|
|
my $osuser = "os:$^O user:".(getlogin || getpwuid($<) || "unknown");
|
|
Log 0, "Featurelevel: $featurelevel";
|
|
Log 0, "Server started with ".int(keys %defs).
|
|
" defined entities ($attr{global}{version} perl:$] $osuser pid:$$)";
|
|
execFhemTestFile();
|
|
|
|
################################################
|
|
# Main Loop
|
|
sub MAIN {MAIN:}; #Dummy
|
|
|
|
|
|
my $errcount= 0;
|
|
$gotSig = undef if($gotSig && $gotSig eq "HUP");
|
|
while (1) {
|
|
my ($rout,$rin, $wout,$win, $eout,$ein) = ('','', '','', '','');
|
|
my $nfound = 0;
|
|
|
|
my $timeout = HandleTimeout();
|
|
|
|
foreach my $p (keys %selectlist) {
|
|
my $hash = $selectlist{$p};
|
|
if(defined($hash->{FD})) {
|
|
vec($rin, $hash->{FD}, 1) = 1
|
|
if(!defined($hash->{directWriteFn}) && !$hash->{wantWrite} );
|
|
vec($win, $hash->{FD}, 1) = 1
|
|
if( (defined($hash->{directWriteFn}) ||
|
|
defined($hash->{$wbName}) ||
|
|
$hash->{wantWrite} ) && !$hash->{wantRead} );
|
|
}
|
|
vec($ein, $hash->{EXCEPT_FD}, 1) = 1
|
|
if(defined($hash->{"EXCEPT_FD"}));
|
|
if($hash->{SSL} && $hash->{CD} &&
|
|
$hash->{CD}->can('pending') && $hash->{CD}->pending()) {
|
|
vec($rout, $hash->{FD}, 1) = 1;
|
|
$nfound++;
|
|
}
|
|
}
|
|
$timeout = $readytimeout if(keys(%readyfnlist) &&
|
|
(!defined($timeout) || $timeout > $readytimeout));
|
|
$timeout = 5 if $winService->{AsAService} && $timeout > 5;
|
|
$nfound = select($rout=$rin, $wout=$win, $eout=$ein, $timeout) if(!$nfound);
|
|
my $err = int($!);
|
|
|
|
$winService->{serviceCheck}->() if($winService->{serviceCheck});
|
|
if($gotSig) {
|
|
CommandShutdown(undef, undef) if($gotSig eq "TERM");
|
|
CommandRereadCfg(undef, "") if($gotSig eq "HUP");
|
|
$attr{global}{verbose} = 5 if($gotSig eq "USR1");
|
|
$gotSig = undef;
|
|
}
|
|
|
|
if($nfound < 0) {
|
|
next if($err==0 || $err==4); # 4==EINTR
|
|
|
|
Log 1, "ERROR: Select error $nfound ($err), error count= $errcount";
|
|
$errcount++;
|
|
|
|
# Handling "Bad file descriptor". This is a programming error.
|
|
# 9/10038 => BADF, 11=>EAGAIN. don't want to "use errno.ph"
|
|
if($err == 11 || $err == 9 || $err == 10038) {
|
|
my $nbad = 0;
|
|
foreach my $p (keys %selectlist) {
|
|
my ($tin, $tout) = ('', '');
|
|
vec($tin, $selectlist{$p}{FD}, 1) = 1;
|
|
if(select($tout=$tin, undef, undef, 0) < 0) {
|
|
Log 1, "Found and deleted bad fileno for $p";
|
|
delete($selectlist{$p});
|
|
$nbad++;
|
|
}
|
|
}
|
|
next if($nbad > 0);
|
|
next if($errcount <= 3);
|
|
}
|
|
die("Select error $nfound ($err)\n");
|
|
} else {
|
|
$errcount= 0;
|
|
}
|
|
|
|
###############################
|
|
# Message from the hardware (FHZ1000/WS3000/etc) via select or the Ready
|
|
# Function. The latter ist needed for Windows, where USB devices are not
|
|
# reported by select, but is used by unix too, to check if the device is
|
|
# attached again.
|
|
foreach my $p (keys %selectlist) {
|
|
next if(!$p); # Deleted in the loop
|
|
my $hash = $selectlist{$p};
|
|
my $isDev = ($hash && $hash->{NAME} && $defs{$hash->{NAME}});
|
|
my $isDirect = ($hash && ($hash->{directReadFn} || $hash->{directWriteFn}));
|
|
next if(!$isDev && !$isDirect);
|
|
|
|
if(defined($hash->{FD}) && vec($rout, $hash->{FD}, 1)) {
|
|
delete $hash->{wantRead};
|
|
|
|
if($hash->{directReadFn}) {
|
|
$hash->{directReadFn}($hash);
|
|
} else {
|
|
CallFn($hash->{NAME}, "ReadFn", $hash);
|
|
}
|
|
}
|
|
|
|
if( defined($hash->{FD}) && vec($wout, $hash->{FD}, 1)) {
|
|
delete $hash->{wantWrite};
|
|
|
|
if($hash->{directWriteFn}) {
|
|
$hash->{directWriteFn}($hash);
|
|
|
|
} elsif(defined($hash->{$wbName})) {
|
|
my $wb = $hash->{$wbName};
|
|
alarm($hash->{ALARMTIMEOUT}) if($hash->{ALARMTIMEOUT});
|
|
|
|
my $ret;
|
|
eval { $ret = syswrite($hash->{CD}, $wb); };
|
|
if($@) {
|
|
Log 4, "$hash->{NAME} syswrite: $@";
|
|
if($hash->{TEMPORARY}) {
|
|
TcpServer_Close($hash);
|
|
CommandDelete(undef, $hash->{NAME});
|
|
}
|
|
next;
|
|
}
|
|
|
|
my $werr = int($!);
|
|
alarm(0) if($hash->{ALARMTIMEOUT});
|
|
|
|
if(!defined($ret) && $werr == EWOULDBLOCK ) {
|
|
$hash->{wantRead} = 1
|
|
if(TcpServer_WantRead($hash));
|
|
|
|
} elsif(!$ret) { # zero=EOF, undef=error
|
|
Log 4, "$hash->{NAME} write error to $p";
|
|
if($hash->{TEMPORARY}) {
|
|
TcpServer_Close($hash);
|
|
CommandDelete(undef, $hash->{NAME})
|
|
}
|
|
|
|
} else {
|
|
if($ret >= length($wb)) { # for the > see Forum #29963
|
|
delete($hash->{$wbName});
|
|
if($hash->{WBCallback}) {
|
|
no strict "refs";
|
|
my $ret = &{$hash->{WBCallback}}($hash);
|
|
use strict "refs";
|
|
delete $hash->{WBCallback};
|
|
}
|
|
} else {
|
|
$hash->{$wbName} = substr($wb, $ret);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if(defined($hash->{"EXCEPT_FD"}) && vec($eout, $hash->{EXCEPT_FD}, 1)) {
|
|
CallFn($hash->{NAME}, "ExceptFn", $hash);
|
|
}
|
|
}
|
|
|
|
foreach my $p (keys %readyfnlist) {
|
|
my $h = $readyfnlist{$p};
|
|
next if(!$h); # due to rereadcfg / delete
|
|
next if($h->{NEXT_OPEN} && gettimeofday() < $h->{NEXT_OPEN});
|
|
|
|
$h->{_readyKey} = $p; # Endless-Loop-Debugging #111959
|
|
if(CallFn($h->{NAME}, "ReadyFn", $h)) {
|
|
if($readyfnlist{$p}) { # delete itself inside ReadyFn
|
|
CallFn($h->{NAME}, "ReadFn", $h);
|
|
}
|
|
}
|
|
delete($h->{_readyKey});
|
|
|
|
}
|
|
|
|
}
|
|
|
|
################################################
|
|
#Functions ahead, no more "plain" code
|
|
|
|
################################################
|
|
sub
|
|
IsDevice($;$)
|
|
{
|
|
my $devname = shift;
|
|
my $devtype = shift;
|
|
|
|
return 1
|
|
if ( defined($devname)
|
|
&& defined( $defs{$devname} )
|
|
&& (!$devtype || $devtype eq "" ) );
|
|
|
|
return 1
|
|
if ( defined($devname)
|
|
&& defined( $defs{$devname} )
|
|
&& defined( $defs{$devname}{TYPE} )
|
|
&& $defs{$devname}{TYPE} =~ m/^$devtype$/ );
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub
|
|
IsDummy($)
|
|
{
|
|
my $devname = shift;
|
|
|
|
return 1 if(defined($attr{$devname}) && $attr{$devname}{dummy});
|
|
return 0;
|
|
}
|
|
|
|
sub
|
|
IsIgnored($)
|
|
{
|
|
my $devname = shift;
|
|
if($devname &&
|
|
defined($attr{$devname}) && $attr{$devname}{ignore}) {
|
|
Log 4, "Ignoring $devname";
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub
|
|
IsDisabled($)
|
|
{
|
|
my $devname = shift;
|
|
return 0 if(!$devname); # no check for $attr{$devname}, #92623
|
|
|
|
return 1 if($attr{$devname}{disable});
|
|
return 3 if($defs{$devname} && $defs{$devname}{STATE} &&
|
|
$defs{$devname}{STATE} eq "inactive");
|
|
return 3 if(ReadingsVal($devname, "state", "") eq "inactive");
|
|
|
|
my $dfi = $attr{$devname}{disabledForIntervals};
|
|
if(defined($dfi)) {
|
|
$dfi =~ s/{([^\x7d]*)}/AnalyzePerlCommand(undef,$1)/ge; # Forum #69787
|
|
my ($sec,$min,$hour,$mday,$month,$year,$wday,$yday,$isdst) =
|
|
localtime(gettimeofday());
|
|
my $dhms = sprintf("%s\@%02d:%02d:%02d", $wday, $hour, $min, $sec);
|
|
foreach my $ft (split(" ", $dfi)) {
|
|
my ($from, $to) = split("-", $ft);
|
|
if(defined($from) && defined($to)) {
|
|
$from = "$wday\@$from" if(index($from,"@") < 0);
|
|
$to = "$wday\@$to" if(index($to, "@") < 0);
|
|
return 2 if($from le $dhms && $dhms le $to);
|
|
}
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
|
|
################################################
|
|
sub
|
|
IsIoDummy($)
|
|
{
|
|
my $name = shift;
|
|
|
|
return IsDummy($defs{$name}{IODev}{NAME})
|
|
if($defs{$name} && $defs{$name}{IODev});
|
|
return 1;
|
|
}
|
|
|
|
|
|
################################################
|
|
sub
|
|
GetLogLevel(@)
|
|
{
|
|
my ($dev,$deflev) = @_;
|
|
my $df = defined($deflev) ? $deflev : 2;
|
|
|
|
return $df if(!defined($dev));
|
|
return $attr{$dev}{loglevel}
|
|
if(defined($attr{$dev}) && defined($attr{$dev}{loglevel}));
|
|
return $df;
|
|
}
|
|
|
|
sub
|
|
GetVerbose($)
|
|
{
|
|
my ($dev) = @_;
|
|
if(defined($dev) &&
|
|
defined($attr{$dev}) &&
|
|
defined (my $devlevel = $attr{$dev}{verbose})) {
|
|
return $devlevel;
|
|
|
|
} else {
|
|
return $attr{global}{verbose};
|
|
|
|
}
|
|
}
|
|
|
|
sub
|
|
GetType($;$)
|
|
{
|
|
my $devname = shift;
|
|
my $default = shift;
|
|
|
|
return $default unless ( IsDevice($devname) && $defs{$devname}{TYPE} );
|
|
return $defs{$devname}{TYPE};
|
|
}
|
|
|
|
|
|
################################################
|
|
# the new Log with integrated loglevel checking
|
|
sub
|
|
Log3($$$)
|
|
{
|
|
my ($dev, $loglevel, $text) = @_;
|
|
|
|
$dev = $dev->{NAME} if(defined($dev) && ref($dev) eq "HASH");
|
|
|
|
if(defined($dev) &&
|
|
defined($attr{$dev}) &&
|
|
defined (my $devlevel = $attr{$dev}{verbose})) {
|
|
return if($loglevel > $devlevel);
|
|
|
|
} else {
|
|
return if($loglevel > $attr{global}{verbose});
|
|
|
|
}
|
|
return if(defined($defs{global}{ignoreRegexpObj}) &&
|
|
$text =~ $defs{global}{ignoreRegexpObj});
|
|
|
|
my ($seconds, $microseconds) = gettimeofday();
|
|
my @t = localtime($seconds);
|
|
my $nfile = ResolveDateWildcards($attr{global}{logfile}, @t);
|
|
OpenLogfile($nfile) if(!$currlogfile || $currlogfile ne $nfile);
|
|
|
|
my $tim = sprintf("%04d.%02d.%02d %02d:%02d:%02d",
|
|
$t[5]+1900,$t[4]+1,$t[3], $t[2],$t[1],$t[0]);
|
|
if($attr{global}{mseclog}) {
|
|
$tim .= sprintf(".%03d", $microseconds/1000);
|
|
}
|
|
|
|
if($logopened) {
|
|
print $LOG "$tim $loglevel: $text\n";
|
|
} else {
|
|
print "$tim $loglevel: $text\n";
|
|
}
|
|
|
|
no strict "refs";
|
|
foreach my $li (keys %logInform) {
|
|
if($defs{$li}) { # Function wont be called for WARNING, don't know why
|
|
&{$logInform{$li}}($li, "$tim $loglevel: $text");
|
|
} else {
|
|
delete $logInform{$li};
|
|
}
|
|
}
|
|
use strict "refs";
|
|
|
|
return undef;
|
|
}
|
|
|
|
################################################
|
|
sub
|
|
Log($$)
|
|
{
|
|
my ($loglevel, $text) = @_;
|
|
Log3(undef, $loglevel, $text);
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
IOWrite($@)
|
|
{
|
|
my ($hash, @a) = @_;
|
|
|
|
my $dev = $hash->{NAME};
|
|
return if(IsDummy($dev) || IsIgnored($dev));
|
|
my $iohash = $hash->{IODev};
|
|
if(!$iohash ||
|
|
!$iohash->{TYPE} ||
|
|
!$modules{$iohash->{TYPE}} ||
|
|
!$modules{$iohash->{TYPE}}{WriteFn}) {
|
|
Log 5, "No IO device or WriteFn found for $dev";
|
|
return;
|
|
}
|
|
|
|
return if(IsDummy($iohash->{NAME}));
|
|
|
|
no strict "refs";
|
|
my $ret = &{$modules{$iohash->{TYPE}}{WriteFn}}($iohash, @a);
|
|
use strict "refs";
|
|
return $ret;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandIOWrite($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my @a = split(" ", $param);
|
|
|
|
return "Usage: iowrite <iodev> <param> ..." if(int(@a) < 2);
|
|
|
|
my $name = shift(@a);
|
|
my $hash = $defs{$name};
|
|
return "$name not found" if(!$hash);
|
|
return undef if(IsDummy($name) || IsIgnored($name));
|
|
if(!$hash->{TYPE} ||
|
|
!$modules{$hash->{TYPE}} ||
|
|
!$modules{$hash->{TYPE}}{WriteFn}) {
|
|
Log 1, "No IO device or WriteFn found for $name";
|
|
return;
|
|
}
|
|
unshift(@a, "") if(int(@a) == 1);
|
|
no strict "refs";
|
|
my $ret = &{$modules{$hash->{TYPE}}{WriteFn}}($hash, @a);
|
|
use strict "refs";
|
|
return $ret;
|
|
}
|
|
|
|
|
|
#####################################
|
|
# i.e. split a line by ; (escape ;;), and execute each
|
|
sub
|
|
AnalyzeCommandChain($$;$)
|
|
{
|
|
my ($c, $cmd) = @_;
|
|
my @ret;
|
|
|
|
if($cmd =~ m/^[ \t]*(#.*)?$/) { # Save comments
|
|
if(!$init_done) {
|
|
if($currcfgfile ne AttrVal("global", "statefile", "")) {
|
|
my $nr = $devcount++;
|
|
$comments{$nr}{TEXT} = $cmd;
|
|
$comments{$nr}{CFGFN} = $currcfgfile
|
|
if($currcfgfile ne AttrVal("global", "configfile", "") &&
|
|
!configDBUsed());
|
|
}
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
$cmd =~ s/^\s*#.*$//s; # Remove comments at the beginning of the line
|
|
|
|
$cmd =~ s/;;/SeMiCoLoN/g;
|
|
my @saveCmdList = @cmdList; # Needed for recursive calls
|
|
@cmdList = split(";", $cmd);
|
|
my $subcmd;
|
|
my $localEvalSpecials = $evalSpecials;
|
|
while(defined($subcmd = shift @cmdList)) {
|
|
$subcmd =~ s/SeMiCoLoN/;/g;
|
|
$evalSpecials = $localEvalSpecials;
|
|
my $lret = AnalyzeCommand($c, $subcmd, "ACC");
|
|
push(@ret, $lret) if(defined($lret));
|
|
}
|
|
@cmdList = @saveCmdList;
|
|
$evalSpecials = undef;
|
|
return join("\n", @ret) if(@ret);
|
|
return undef;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
AnalyzePerlCommand($$;$)
|
|
{
|
|
my ($cl, $cmd, $calledFromChain) = @_; # third parmeter is deprecated
|
|
|
|
return "Forbidden command $cmd." if($cl && !Authorized($cl, "cmd", "perl"));
|
|
|
|
$cmd =~ s/\\ *\n/ /g; # Multi-line. Probably not needed anymore
|
|
|
|
# Make life easier for oneliners:
|
|
if($featurelevel <= 5.6) {
|
|
%value = ();
|
|
foreach my $d (keys %defs) {
|
|
$value{$d} = $defs{$d}{STATE}
|
|
}
|
|
}
|
|
my ($sec,$min,$hour,$mday,$month,$year,$wday,$yday,$isdst) =
|
|
localtime(gettimeofday());
|
|
$month++; $year+=1900;
|
|
my $today = sprintf('%04d-%02d-%02d', $year,$month,$mday);
|
|
my $hms = sprintf("%02d:%02d:%02d", $hour, $min, $sec);
|
|
my $we = IsWe(undef, $wday);
|
|
|
|
if($evalSpecials) {
|
|
$cmd = join("", map {
|
|
my $n = substr($_,1); # ignore the legacy %
|
|
my $ref = ref($evalSpecials->{$_});
|
|
$ref eq "ARRAY" ? "my \@$n=\@{\$evalSpecials->{'$_'}};" :
|
|
$ref eq "HASH" ? "my \%$n=\%{\$evalSpecials->{'$_'}};" :
|
|
"my \$$n= \$evalSpecials->{'$_'};";
|
|
} sort keys %{$evalSpecials}) . $cmd;
|
|
}
|
|
|
|
$cmdFromAnalyze = $cmd;
|
|
my $ret = eval $cmd;
|
|
if($@) {
|
|
$ret = $@;
|
|
Log 1, "ERROR evaluating $cmd: $ret";
|
|
}
|
|
|
|
# Normally this is deleted in AnalyzeCommandChain, but ECMDDevice calls us
|
|
# directly, and combining perl with something else isnt allowed anyway.
|
|
$evalSpecials = undef if(!$calledFromChain);
|
|
$cmdFromAnalyze = undef;
|
|
return $ret;
|
|
}
|
|
|
|
sub
|
|
AnalyzeCommand($$;$)
|
|
{
|
|
my ($cl, $cmd, $calledFromChain) = @_;
|
|
|
|
$cmd = "" if(!defined($cmd)); # Forum #29963
|
|
$cmd =~ s/^(\n|[ \t])*//;# Strip space or \n at the begginning
|
|
$cmd =~ s/[ \t]*$//;
|
|
|
|
Log 5, "Cmd: >$cmd<";
|
|
if(!$cmd) {
|
|
$evalSpecials = undef if(!$calledFromChain || $calledFromChain ne "ACC");
|
|
return undef;
|
|
}
|
|
|
|
if($cmd =~ m/^{.*}$/s) { # Perl code
|
|
return AnalyzePerlCommand($cl, $cmd, 1);
|
|
}
|
|
|
|
if($cmd =~ m/^"(.*)"$/s) { # Shell code in bg, to be able to call us from it
|
|
return "Forbidden command $cmd." if($cl && !Authorized($cl,"cmd","shell"));
|
|
if($evalSpecials) {
|
|
map { $ENV{substr($_,1)} = $evalSpecials->{$_}; } keys %{$evalSpecials};
|
|
$evalSpecials = undef if(!$calledFromChain || $calledFromChain ne "ACC");
|
|
}
|
|
my $out = "";
|
|
$out = ">> $currlogfile 2>&1" if($currlogfile ne "-" && $^O ne "MSWin32");
|
|
system("$1 $out &");
|
|
return undef;
|
|
}
|
|
|
|
$cmd =~ s/^[ \t]*//;
|
|
if($evalSpecials) {
|
|
map { my $n = substr($_,1); my $v = $evalSpecials->{$_};
|
|
$cmd =~ s/\$$n/$v/g; } sort { $b cmp $a } keys %{$evalSpecials};
|
|
$evalSpecials = undef if(!$calledFromChain || $calledFromChain ne "ACC");
|
|
}
|
|
my ($fn, $param) = split("[ \t][ \t]*", $cmd, 2);
|
|
return undef if(!$fn);
|
|
|
|
|
|
#############
|
|
# Search for abbreviation
|
|
sub
|
|
getAbbr($$;$)
|
|
{
|
|
my ($fn,$h,$isMod) = @_;
|
|
my $lcfn = lc($fn);
|
|
my $fnlen = length($fn);
|
|
return $fn if(defined($h->{$fn}) && ($isMod || $h->{$fn}{Fn})); # speedup
|
|
foreach my $f (sort keys %{$h}) {
|
|
if(length($f) >= $fnlen &&
|
|
lc(substr($f,0,$fnlen)) eq $lcfn &&
|
|
($isMod || $h->{$f}{Fn})) {
|
|
Log 5, "AnalyzeCommand: trying $f for $fn";
|
|
return $f;
|
|
}
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
my $lfn = getAbbr($fn,\%cmds);
|
|
$fn = $lfn if($lfn);
|
|
$fn = $cmds{$fn}{ReplacedBy}
|
|
if(defined($cmds{$fn}) && defined($cmds{$fn}{ReplacedBy}));
|
|
|
|
#############
|
|
# autoload command with ModuleName
|
|
if(!$cmds{$fn} || !defined($cmds{$fn}{Fn})) {
|
|
my $modName;
|
|
$modName = $cmds{$fn}{ModuleName} if($cmds{$fn} && $cmds{$fn}{ModuleName});
|
|
$modName = getAbbr($fn,\%modules,1) if(!$modName);
|
|
|
|
LoadModule($modName) if($modName);
|
|
my $lfn = getAbbr($fn,\%cmds);
|
|
$fn = $lfn if($lfn);
|
|
}
|
|
|
|
return "Unknown command $fn, try help." if(!$cmds{$fn} || !$cmds{$fn}{Fn});
|
|
|
|
return "Forbidden command $fn."
|
|
if($cl &&
|
|
$cmd !~ m/^(set|get|attr)\s+[^ ]+\s+\?$/ &&
|
|
!Authorized($cl, "cmd", $fn));
|
|
|
|
if($cl && $cmds{$fn}{ClientFilter} &&
|
|
$cl->{TYPE} !~ m/$cmds{$fn}{ClientFilter}/) {
|
|
return "This command ($fn) is not valid for this input channel.";
|
|
}
|
|
|
|
$param = "" if(!defined($param));
|
|
no strict "refs";
|
|
my $ret = &{$cmds{$fn}{Fn} }($cl, $param, $fn);
|
|
use strict "refs";
|
|
return undef if(defined($ret) && $ret eq "");
|
|
return $ret;
|
|
}
|
|
|
|
sub
|
|
devspec2array($;$$)
|
|
{
|
|
my ($name, $cl, $initialList) = @_;
|
|
|
|
return "" if(!defined($name));
|
|
if(defined($defs{$name})) {
|
|
return "" if($cl && !Authorized($cl, "devicename", $name));
|
|
|
|
# FHEM2FHEM LOG mode fake device, avoid local set/attr/etc operations on it
|
|
return "FHEM2FHEM_FAKE_$name" if($defs{$name}{FAKEDEVICE});
|
|
return $name;
|
|
}
|
|
|
|
my (@ret, $isAttr);
|
|
foreach my $l (split(",", $name)) { # List of elements
|
|
|
|
if(defined($defs{$l})) {
|
|
push @ret, $l;
|
|
next;
|
|
}
|
|
|
|
my @names = $initialList ? @{$initialList} : sort keys %defs;
|
|
my @res;
|
|
foreach my $dName (split(":FILTER=", $l)) {
|
|
my ($n,$op,$re) = ("NAME","=",$dName);
|
|
if($dName =~ m/^(.*?)(=|!=|~|!~|<=|>=|<|>)(.*)$/) {
|
|
($n,$op,$re) = ($1,$2,$3);
|
|
$isAttr = 1; # Compatibility: return "" instead of $name
|
|
}
|
|
($n,$op,$re) = ($1,"eval","") if($dName =~ m/^{(.*)}$/);
|
|
|
|
my $fType="";
|
|
if($n =~ m/^(.:)(.*$)/) {
|
|
$fType = $1;
|
|
$n = $2;
|
|
}
|
|
@res=();
|
|
foreach my $d (@names) {
|
|
next if($attr{$d} && $attr{$d}{ignore});
|
|
|
|
if($op eq "eval") {
|
|
my $exec = EvalSpecials($n, %{{"%DEVICE"=>$d}});
|
|
push @res, $d if(AnalyzePerlCommand($cl, $exec));
|
|
next;
|
|
}
|
|
|
|
my $hash = $defs{$d};
|
|
if(!$hash->{TYPE}) {
|
|
Log 1, "Error: >$d< has no TYPE, but following keys: >".
|
|
join(",", sort keys %{$hash})."<";
|
|
delete($defs{$d});
|
|
next;
|
|
}
|
|
my $val;
|
|
$val = $hash->{$n} if(!$fType || $fType eq "i:");
|
|
if(!defined($val) && (!$fType || $fType eq "r:")) {
|
|
my $r = $hash->{READINGS};
|
|
$val = $r->{$n}{VAL} if($r && $r->{$n});
|
|
}
|
|
if(!defined($val) && (!$fType || $fType eq "a:")) {
|
|
$val = $attr{$d}{$n} if($attr{$d});
|
|
}
|
|
$val="" if(!defined($val));
|
|
$val = $val->{NAME} if(ref($val) eq 'HASH' && $val->{NAME}); # IODev
|
|
|
|
my $lre = ($n eq "room" || $n eq "group") ?
|
|
"(^|,)($re)(,|\$)" : "^($re)\$";
|
|
my $valReNum =(looks_like_number($val) && looks_like_number($re) ? 1:0);
|
|
eval { # a bad regexp is deadly
|
|
if(($op eq "=" && $val =~ m/$lre/s) ||
|
|
($op eq "!=" && $val !~ m/$lre/s) ||
|
|
($op eq "~" && $val =~ m/$lre/is) ||
|
|
($op eq "!~" && $val !~ m/$lre/is) ||
|
|
($op eq "<" && $valReNum && $val < $re) ||
|
|
($op eq ">" && $valReNum && $val > $re) ||
|
|
($op eq "<=" && $valReNum && $val <= $re) ||
|
|
($op eq ">=" && $valReNum && $val >= $re)) {
|
|
push @res, $d
|
|
}
|
|
};
|
|
|
|
if($@) {
|
|
warn "devspec2array $name: $@"; #128362
|
|
return $name;
|
|
}
|
|
}
|
|
@names = @res;
|
|
}
|
|
push @ret,@res;
|
|
}
|
|
return $name if(!@ret && !$isAttr);
|
|
@ret = grep { Authorized($cl, "devicename", $_, 1) } @ret if($cl);
|
|
return @ret;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandInclude($$)
|
|
{
|
|
my ($cl, $arg) = @_;
|
|
my $fh;
|
|
my @ret;
|
|
my $oldcfgfile;
|
|
|
|
my $type = ($unicodeEncoding ? "< :encoding(UTF-8)" : "<");
|
|
if(!open($fh, $type, $arg)) {
|
|
return "Can't open $arg: $!";
|
|
}
|
|
|
|
Log 1, "Including $arg";
|
|
my @t = localtime(gettimeofday());
|
|
my $gcfg = ResolveDateWildcards(AttrVal("global", "configfile", ""), @t);
|
|
my $stf = ResolveDateWildcards(AttrVal("global", "statefile", ""), @t);
|
|
if(!$init_done && $arg ne $stf && $arg ne $gcfg) {
|
|
my $nr = $devcount++;
|
|
$comments{$nr}{TEXT} = "include $arg";
|
|
$comments{$nr}{CFGFN} = $currcfgfile if($currcfgfile ne $gcfg);
|
|
}
|
|
$oldcfgfile = $currcfgfile;
|
|
$currcfgfile = $arg;
|
|
|
|
my $bigcmd = "";
|
|
my $lineno = 0;
|
|
$rcvdquit = 0;
|
|
while(my $l = <$fh>) {
|
|
$lineno++;
|
|
$l =~ s/[\r\n]//g;
|
|
|
|
if($l =~ m/^(.*)\\ *$/) { # Multiline commands
|
|
$bigcmd .= "$1\n";
|
|
|
|
} else {
|
|
my $tret = AnalyzeCommandChain($cl, $bigcmd . $l);
|
|
if(defined($tret)) {
|
|
Log 5, "$arg line $lineno returned >$tret<";
|
|
push @ret, $tret;
|
|
}
|
|
$bigcmd = "";
|
|
}
|
|
last if($rcvdquit);
|
|
|
|
}
|
|
$currcfgfile = $oldcfgfile;
|
|
close($fh);
|
|
return join("\n", @ret) if(@ret);
|
|
return undef;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
OpenLogfile($)
|
|
{
|
|
my $param = shift;
|
|
|
|
close($LOG) if($LOG);
|
|
$logopened=0;
|
|
$currlogfile = $param;
|
|
|
|
# STDOUT is closed in windows services per default
|
|
|
|
if(!$winService->{AsAService} && $currlogfile eq "-") {
|
|
open($LOG, '>&STDOUT') || die "Can't dup stdout: $!";
|
|
|
|
} else {
|
|
$defs{global}{currentlogfile} = $param;
|
|
$defs{global}{logfile} = $attr{global}{logfile};
|
|
HandleArchiving($defs{global});
|
|
|
|
restoreDir_mkDir($currlogfile=~m,^/,? "":".", $currlogfile, 1);
|
|
open($LOG, ">>$currlogfile") || return("Can't open $currlogfile: $!");
|
|
redirectStdinStdErr();
|
|
|
|
}
|
|
binmode($LOG, ":encoding(UTF-8)") if($unicodeEncoding);
|
|
$LOG->autoflush(1);
|
|
$logopened = 1;
|
|
$defs{global}{FD} = $LOG->fileno(); # ??
|
|
return undef;
|
|
}
|
|
|
|
sub
|
|
redirectStdinStdErr()
|
|
{
|
|
# Redirect stdin/stderr
|
|
return if(!$currlogfile || $currlogfile eq "-");
|
|
|
|
open STDIN, '</dev/null' or print "Can't read /dev/null: $!\n";
|
|
|
|
close(STDERR);
|
|
open(STDERR, ">>$currlogfile") or print "Can't append STDERR to log: $!\n";
|
|
STDERR->autoflush(1);
|
|
|
|
close(STDOUT);
|
|
open STDOUT, '>&STDERR' or print "Can't dup stdout: $!\n";
|
|
STDOUT->autoflush(1);
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
CommandRereadCfg($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my $name = ($cl ? $cl->{NAME} : "__anonymous__");
|
|
my $cfgfile = ($param ? $param : $attr{global}{configfile});
|
|
return "Cannot open $cfgfile: $!"
|
|
if(! -f $cfgfile && !configDBUsed());
|
|
|
|
$attr{global}{configfile} = $cfgfile;
|
|
WriteStatefile();
|
|
|
|
$reread_active=1;
|
|
$init_done = 0;
|
|
foreach my $d (sort { $defs{$b}{NR} <=> $defs{$a}{NR} } keys %defs) {
|
|
my $ret = CallFn($d, "UndefFn", $defs{$d}, $d)
|
|
if($name && $name ne $d);
|
|
Log 1, "$d is against deletion ($ret), continuing with rereadcfg anyway"
|
|
if($ret);
|
|
delete $defs{$d};
|
|
}
|
|
|
|
%comments = ();
|
|
%defs = ();
|
|
%attr = ();
|
|
%selectlist = ();
|
|
%readyfnlist = ();
|
|
my $informMe = $inform{$name};
|
|
%inform = ();
|
|
%fuuidHash = ();
|
|
%intAt = ();
|
|
@intAtA = ();
|
|
%sleepers = ();
|
|
%ntfyHash = ();
|
|
|
|
doGlobalDef($cfgfile);
|
|
my $ret;
|
|
|
|
if(configDBUsed()) {
|
|
$ret = cfgDB_ReadAll($cl);
|
|
|
|
} else {
|
|
setGlobalAttrBeforeFork($cfgfile);
|
|
|
|
$ret = CommandInclude($cl, $cfgfile);
|
|
if($attr{global}{statefile} && -r $attr{global}{statefile}) {
|
|
my $ret2 = CommandInclude($cl, $attr{global}{statefile});
|
|
$ret = (defined($ret) ? "$ret\n$ret2" : $ret2) if(defined($ret2));
|
|
}
|
|
}
|
|
applyGlobalAttrFromEnv();
|
|
|
|
$defs{$name} = $selectlist{$name} = $cl
|
|
if($name && $name ne "__anonymous__");
|
|
$inform{$name} = $informMe if($informMe);
|
|
@structChangeHist = ();
|
|
$lastDefChange++;
|
|
|
|
finish_init();
|
|
|
|
DoTrigger("global", "REREADCFG", 1);
|
|
|
|
$init_done = 1;
|
|
$reread_active=0;
|
|
return $ret;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandQuit($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
|
|
if(!$cl) {
|
|
$rcvdquit = 1;
|
|
} else {
|
|
$cl->{rcvdQuit} = 1;
|
|
return "Bye..." if($cl->{prompt});
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub
|
|
GetAllReadings($)
|
|
{
|
|
my ($d) = @_;
|
|
my @ret;
|
|
my $val = $defs{$d}{STATE};
|
|
if(defined($val) &&
|
|
$val ne "unknown" &&
|
|
$val ne "Initialized" &&
|
|
$val ne "" &&
|
|
$val ne "???") {
|
|
$val =~ s/;/;;/g;
|
|
$val =~ s/([ \t])/sprintf("\\%03o",ord($1))/eg if($val =~ m/^[ \t]*$/);
|
|
$val =~ s/\n/\\\n/g;
|
|
push @ret, "setstate $d $val";
|
|
}
|
|
|
|
#############
|
|
# Now the detailed list
|
|
my $r = $defs{$d}{READINGS};
|
|
if($r) {
|
|
foreach my $c (sort keys %{$r}) {
|
|
|
|
my $rd = $r->{$c};
|
|
if(!defined($rd->{TIME})) {
|
|
Log 4, "WriteStatefile $d $c: Missing TIME, using current time";
|
|
$rd->{TIME} = TimeNow();
|
|
}
|
|
|
|
if(!defined($rd->{VAL})) {
|
|
Log 4, "WriteStatefile $d $c: Missing VAL, setting it to 0";
|
|
$rd->{VAL} = 0;
|
|
}
|
|
my $val = $rd->{VAL};
|
|
$val =~ s/;/;;/g;
|
|
$val =~ s/\n/\\\n/g;
|
|
push @ret,"setstate $d $rd->{TIME} $c $val";
|
|
}
|
|
}
|
|
return @ret;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
WriteStatefile()
|
|
{
|
|
if(configDBUsed()) {
|
|
return cfgDB_SaveState();
|
|
}
|
|
|
|
my $stateFile = AttrVal('global','statefile',undef);
|
|
return "No statefile specified" if(!defined($stateFile));
|
|
|
|
my $now = gettimeofday();
|
|
my @t = localtime($now);
|
|
$stateFile = ResolveDateWildcards($stateFile, @t);
|
|
|
|
my $SFH;
|
|
if(!open($SFH, ">$stateFile")) {
|
|
my $msg = "WriteStatefile: Cannot open $stateFile: $!";
|
|
Log 1, $msg;
|
|
return $msg;
|
|
}
|
|
binmode($SFH, ":encoding(UTF-8)") if($unicodeEncoding);
|
|
|
|
my $t = localtime($now);
|
|
print $SFH "#$t\n";
|
|
|
|
foreach my $d (sort keys %defs) {
|
|
next if($defs{$d}{TEMPORARY});
|
|
if($defs{$d}{VOLATILE}) {
|
|
my $def = $defs{$d}{DEF};
|
|
$def =~ s/;/;;/g; # follow-on-for-timer at
|
|
$def =~ s/\n/\\\n/g;
|
|
print $SFH "define $d $defs{$d}{TYPE} $def\n";
|
|
}
|
|
|
|
my @arr = GetAllReadings($d);
|
|
print $SFH join("\n", @arr)."\n" if(@arr);
|
|
}
|
|
|
|
return "$attr{global}{statefile}: $!" if(!close($SFH));
|
|
return "";
|
|
}
|
|
|
|
sub
|
|
CommandSetuuid($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
return "setuuid cannot be used after FHEM is initialized" if($init_done);
|
|
my @a = split(" ", $param);
|
|
return "setuuid: Please define $a[0] first" if(!defined($defs{$a[0]}));
|
|
return "setuuid $a[0]: duplicate value, ignoring it" if($fuuidHash{$a[1]});
|
|
$fuuidHash{$a[1]} = $a[1];
|
|
$defs{$a[0]}{FUUID} = $a[1];
|
|
return undef;
|
|
}
|
|
|
|
|
|
sub
|
|
GetDefAndAttr($;$)
|
|
{
|
|
my ($d, $dumpFUUID) = @_;
|
|
my @ret;
|
|
|
|
if($d ne "global") {
|
|
my $def = $defs{$d}{DEF};
|
|
if(defined($def)) {
|
|
$def =~ s/;/;;/g;
|
|
$def =~ s/\n/\\\n/g;
|
|
push @ret,"define $d $defs{$d}{TYPE} $def";
|
|
} else {
|
|
push @ret,"define $d $defs{$d}{TYPE}";
|
|
}
|
|
}
|
|
|
|
push @ret, "setuuid $d $defs{$d}{FUUID}"
|
|
if($dumpFUUID && defined($defs{$d}{FUUID}) && $defs{$d}{FUUID});
|
|
|
|
# exclude attributes, format <deviceName>:<attrName>, space separated list
|
|
my @dontSave = qw(configdb:rescue configdb:nostate configdb:loadversion
|
|
global:configfile global:version);
|
|
foreach my $a (sort {
|
|
return -1 if($a eq "userattr"); # userattr must be first
|
|
return 1 if($b eq "userattr");
|
|
return $a cmp $b;
|
|
} keys %{$attr{$d}}) {
|
|
next if (grep { $_ eq "$d:$a" } @dontSave);
|
|
my $val = $attr{$d}{$a};
|
|
$val =~ s/;/;;/g;
|
|
$val =~ s/\n/\\\n/g;
|
|
push @ret,"attr $d $a $val";
|
|
}
|
|
return @ret;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandSave($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
|
|
if($param && $param eq "?") {
|
|
return "No structural changes." if(!@structChangeHist);
|
|
return "Last unsaved structural changes:\n ".
|
|
join("\n ", @structChangeHist);
|
|
}
|
|
|
|
if(!$cl && !AttrVal("global", "autosave", 1)) { # Forum #78769
|
|
Log 4, "Skipping save, as autosave is disabled";
|
|
return;
|
|
}
|
|
my $restoreDir;
|
|
$restoreDir = restoreDir_init("save") if(!configDBUsed());
|
|
|
|
@structChangeHist = ();
|
|
DoTrigger("global", "SAVE", 1);
|
|
|
|
if(!configDBUsed()) {
|
|
my @t = localtime(gettimeofday());
|
|
my $stf = ResolveDateWildcards(AttrVal("global", "statefile", ""), @t);
|
|
restoreDir_saveFile($restoreDir, $stf);
|
|
}
|
|
|
|
$data{saveID} = createUniqueId(); # for configDB, #126323
|
|
my $ret = WriteStatefile();
|
|
|
|
return $ret if($ret);
|
|
$ret = ""; # cfgDB_SaveState may return undef
|
|
|
|
if(configDBUsed()) {
|
|
$ret = cfgDB_SaveCfg();
|
|
return ($ret ? $ret : "Saved configuration to the DB");
|
|
}
|
|
|
|
$param = $attr{global}{configfile} if(!$param);
|
|
return "No configfile attribute set and no argument specified" if(!$param);
|
|
restoreDir_saveFile($restoreDir, $param);
|
|
my $SFH;
|
|
if(!open($SFH, ">$param")) {
|
|
return "Cannot open $param: $!";
|
|
}
|
|
binmode($SFH, ":encoding(UTF-8)") if($unicodeEncoding);
|
|
my %fh = ("configfile" => $SFH);
|
|
my %skip;
|
|
|
|
my %devByNr;
|
|
map { $devByNr{$defs{$_}{NR}} = $_ } keys %defs;
|
|
my $dumpUuid = (AttrVal("global", "disableFeatures", "") !~ m/\bsaveuuid\b/i);
|
|
|
|
for(my $i = 0; $i < $devcount; $i++) {
|
|
|
|
my ($h, $d);
|
|
if($comments{$i}) {
|
|
$h = $comments{$i};
|
|
|
|
} else {
|
|
$d = $devByNr{$i};
|
|
next if(!defined($d) ||
|
|
$defs{$d}{TEMPORARY} || # e.g. WEBPGM connections
|
|
$defs{$d}{VOLATILE}); # e.g at, will be saved to the statefile
|
|
$h = $defs{$d};
|
|
}
|
|
|
|
my $cfgfile = $h->{CFGFN} ? $h->{CFGFN} : "configfile";
|
|
my $fh = $fh{$cfgfile};
|
|
if(!$fh) {
|
|
restoreDir_saveFile($restoreDir, $cfgfile);
|
|
if(!open($fh, ">$cfgfile")) {
|
|
$ret .= "Cannot open $cfgfile: $!, ignoring its content\n";
|
|
$fh{$cfgfile} = 1;
|
|
$skip{$cfgfile} = 1;
|
|
} else {
|
|
$fh{$cfgfile} = $fh;
|
|
}
|
|
binmode($fh, ":encoding(UTF-8)") if($unicodeEncoding);
|
|
}
|
|
next if($skip{$cfgfile});
|
|
|
|
if(!defined($d)) {
|
|
print $fh $h->{TEXT},"\n";
|
|
next;
|
|
}
|
|
|
|
my @arr = GetDefAndAttr($d, $dumpUuid);
|
|
print $fh join("\n", @arr)."\n" if(@arr);
|
|
|
|
}
|
|
|
|
print $SFH "include $attr{global}{lastinclude}\n"
|
|
if($attr{global}{lastinclude} && $featurelevel <= 5.6);
|
|
|
|
foreach my $key (keys %fh) {
|
|
next if($fh{$key} eq "1"); ## R/O include files
|
|
$ret .= "$key: $!" if(!close($fh{$key}));
|
|
}
|
|
|
|
return ($ret ? $ret : "Wrote configuration to $param");
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CancelDelayedShutdown($)
|
|
{
|
|
my ($d) = @_;
|
|
delete($delayedShutdowns{$d});
|
|
}
|
|
|
|
sub
|
|
DoDelayedShutdown($)
|
|
{
|
|
my ($hash) = @_;
|
|
return CommandShutdown($hash->{cl},$hash->{param},undef,1,$hash->{exitValue})
|
|
if(!keys %delayedShutdowns ||
|
|
$hash->{waitingFor}++ >= $hash->{maxShutdownDelay});
|
|
InternalTimer(gettimeofday()+1, "DoDelayedShutdown", $hash, 0);
|
|
}
|
|
|
|
sub
|
|
DelayedShutdown($$$)
|
|
{
|
|
my ($cl, $param, $exitValue) = @_;
|
|
|
|
return 1 if(keys %delayedShutdowns);
|
|
foreach my $d (sort keys %defs) {
|
|
$delayedShutdowns{$d} = 1 if(CallFn($d, "DelayedShutdownFn", $defs{$d}));
|
|
}
|
|
return 0 if(!keys %delayedShutdowns);
|
|
|
|
my $maxShutdownDelay = AttrVal("global", "maxShutdownDelay", 10);
|
|
Log 1, "Server shutdown delayed due to ".join(",", keys %delayedShutdowns).
|
|
" for max $maxShutdownDelay sec";
|
|
DoTrigger("global", "DELAYEDSHUTDOWN", 1);
|
|
|
|
DoDelayedShutdown(
|
|
{ cl=>$cl, param=>$param, exitValue=>$exitValue,
|
|
waitingFor=>0, maxShutdownDelay=>$maxShutdownDelay } );
|
|
return 1;
|
|
}
|
|
|
|
sub
|
|
CommandShutdown($$;$$$)
|
|
{
|
|
my ($cl, $param, $cmdName, $final, $exitValue) = @_;
|
|
if($param && $param =~ m/^(\d+)$/) {
|
|
$exitValue = $1;
|
|
$param = "";
|
|
}
|
|
return "Usage: shutdown [restart|exitvalue]"
|
|
if($param && $param ne "restart");
|
|
return if(!$final && DelayedShutdown($cl, $param, $exitValue));
|
|
|
|
DoTrigger("global", "SHUTDOWN", 1);
|
|
Log 0, "Server shutdown";
|
|
|
|
foreach my $d (sort keys %defs) {
|
|
CallFn($d, "ShutdownFn", $defs{$d});
|
|
}
|
|
|
|
WriteStatefile();
|
|
unlink($attr{global}{pidfilename}) if($attr{global}{pidfilename});
|
|
|
|
# Avoid restarts in overoptimized browser #105729
|
|
doShutdown({p=>$param, e=>$exitValue}) if(!$cl);
|
|
InternalTimer(time()+1, sub(){doShutdown(@_)}, {p=>$param,e=>$exitValue}, 0);
|
|
}
|
|
|
|
sub
|
|
doShutdown($$)
|
|
{
|
|
my ($param, $exitValue) = ($_[0]->{p}, $_[0]->{e});
|
|
|
|
if($param && $param eq "restart") {
|
|
if ($^O !~ m/Win/) {
|
|
system("(sleep " . AttrVal("global", "restartDelay", 2) .
|
|
"; exec $^X $0 $attr{global}{configfile})&");
|
|
} elsif ($winService->{AsAService}) {
|
|
# use the OS SCM to stop and start the service
|
|
exec('cmd.exe /C net stop fhem & net start fhem');
|
|
}
|
|
}
|
|
exit($exitValue ? $exitValue : 0);
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
ReplaceSetMagic($$@) # Forum #38276
|
|
{
|
|
my $hash = shift;
|
|
my $nsplit = shift;
|
|
my $a = join(" ", @_);
|
|
my $oa = $a;
|
|
|
|
sub
|
|
rsmVal($$$$$)
|
|
{
|
|
my ($all, $t, $d, $n, $s, $val) = @_;
|
|
my $hash = $defs{$d};
|
|
return $all if(!$hash);
|
|
if(!$t || $t eq "r:") {
|
|
my $r = $hash->{READINGS};
|
|
if($s && ($s eq ":t" || $s eq ":sec")) {
|
|
return $all if (!$r || !$r->{$n});
|
|
$val = $r->{$n}{TIME};
|
|
$val = int(gettimeofday()) - time_str2num($val) if($s eq ":sec");
|
|
return $val;
|
|
}
|
|
$val = $r->{$n}{VAL} if($r && $r->{$n});
|
|
}
|
|
$val = $hash->{$n} if(!defined($val) && (!$t || $t eq "i:"));
|
|
$val = $attr{$d}{$n} if(!defined($val) && (!$t || $t eq "a:") && $attr{$d});
|
|
return $all if(!defined($val));
|
|
|
|
if($s && $s =~ /:d|:r|:i/ && $val =~ /(-?\d+(\.\d+)?)/) {
|
|
$val = $1;
|
|
$val = int($val) if($s eq ":i" );
|
|
$val = round($val, defined($1) ? $1 : 1) if($s =~ /^:r(\d)?/);
|
|
$val = round($val, $1) if($s =~ /^:d(\d)/); #100753
|
|
}
|
|
return $val;
|
|
}
|
|
|
|
$a =~s/(\[([ari]:)?([a-zA-Z\d._]+):([a-zA-Z\d._\/-]+)(:(t|sec|i|[dr]\d?))?\])/
|
|
rsmVal($1,$2,$3,$4,$5)/eg;
|
|
|
|
my $esDef = ($evalSpecials ? 1 : 0);
|
|
$evalSpecials->{'%DEV'} = $hash->{NAME};
|
|
$a =~ s/{\((.*?)\)}/AnalyzePerlCommand($hash->{CL},$1,1)/egs;
|
|
$evalSpecials = undef if(!$esDef);;
|
|
|
|
return (undef, @_) if($oa eq $a);
|
|
return (undef, split(/ /, $a, $nsplit));
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
DoSet(@)
|
|
{
|
|
my @a = @_;
|
|
|
|
my $dev = $a[0];
|
|
my $hash = $defs{$dev};
|
|
return "Please define $dev first" if(!$hash);
|
|
return "Bogus entry $dev without TYPE" if(!$hash->{TYPE});
|
|
return "No set implemented for $dev" if(!$modules{$hash->{TYPE}}{SetFn});
|
|
|
|
# No special handling needed fo the Usage check
|
|
return CallFn($dev, "SetFn", $hash,
|
|
$modules{$hash->{TYPE}}->{parseParams} ? parseParams(\@a) : @a)
|
|
if($a[1] && $a[1] eq "?");
|
|
|
|
@a = ReplaceEventMap($dev, \@a, 0) if($attr{$dev}{eventMap});
|
|
my $err;
|
|
($err, @a) = ReplaceSetMagic($hash, 0, @a) if($featurelevel >= 5.7);
|
|
return $err if($err);
|
|
|
|
$hash->{".triggerUsed"} = 0;
|
|
my ($ret, $skipTrigger) = CallFn($dev, "SetFn", $hash,
|
|
$modules{$hash->{TYPE}}->{parseParams} ? parseParams(\@a) : @a);
|
|
return $ret if($ret);
|
|
return undef if($skipTrigger);
|
|
|
|
# Backward compatibility. Use readingsUpdate in SetFn now
|
|
# case: DoSet is called from a notify triggered by DoSet with same dev
|
|
if(defined($hash->{".triggerUsed"}) && $hash->{".triggerUsed"} == 0) {
|
|
shift @a;
|
|
# set arg if the module did not triggered events
|
|
my $arg;
|
|
$arg = join(" ", @a) if(!$hash->{CHANGED} || !int(@{$hash->{CHANGED}}));
|
|
DoTrigger($dev, $arg, 0);
|
|
}
|
|
delete($hash->{".triggerUsed"});
|
|
|
|
return undef;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
CommandSet($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my @a = split("[ \t][ \t]*", $param);
|
|
return "Usage: set <name> <type-dependent-options>\n$namedef" if(int(@a)<1);
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($a[0], $a[1] && $a[1] eq "?" ? undef : $cl)) {
|
|
|
|
$a[0] = $sdev;
|
|
$defs{$sdev}->{CL} = $cl if($defs{$sdev});
|
|
my $ret = DoSet(@a);
|
|
delete $defs{$sdev}->{CL} if($defs{$sdev});
|
|
push @rets, $ret if($ret);
|
|
|
|
}
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
CommandGet($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
|
|
my @a = split("[ \t][ \t]*", $param);
|
|
return "Usage: get <name> <type-dependent-options>\n$namedef" if(int(@a) < 1);
|
|
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($a[0], $a[1] && $a[1] eq "?" ? undef : $cl)) {
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first";
|
|
next;
|
|
}
|
|
if(!$modules{$defs{$sdev}{TYPE}}{GetFn}) {
|
|
push @rets, "No get implemented for $sdev";
|
|
next;
|
|
}
|
|
|
|
$a[0] = $sdev;
|
|
$defs{$sdev}->{CL} = $cl;
|
|
my $ret = CallFn($sdev, "GetFn", $defs{$sdev},
|
|
$modules{$defs{$sdev}->{TYPE}}->{parseParams} ? parseParams(\@a) : @a);
|
|
delete $defs{$sdev}->{CL};
|
|
push @rets, $ret if(defined($ret) && $ret ne "");
|
|
}
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
sub
|
|
asyncOutput($$)
|
|
{
|
|
my ($cl, $ret) = @_;
|
|
return undef if(!$cl || !$cl->{NAME});
|
|
|
|
my $temporary;
|
|
if($defs{$cl->{NAME}}) {
|
|
$cl = $defs{$cl->{NAME}}; # Compatibility
|
|
} else {
|
|
$defs{$cl->{NAME}} = $cl; # timeconsuming answer: get fd ist already closed
|
|
$temporary = 1;
|
|
}
|
|
|
|
CallFn($cl->{NAME}, "AsyncOutputFn", $cl, $ret);
|
|
delete $defs{$cl->{NAME}} if($temporary);
|
|
return undef;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
LoadModule($;$)
|
|
{
|
|
my ($m, $ignoreErr) = @_;
|
|
|
|
if($modules{$m} && !$modules{$m}{LOADED}) { # autoload
|
|
my $o = $modules{$m}{ORDER};
|
|
my $ret = CommandReload(undef, "${o}_$m", $ignoreErr);
|
|
if($ret) {
|
|
Log 0, $ret if(!$ignoreErr);
|
|
return "UNDEFINED";
|
|
}
|
|
|
|
if(!$modules{$m}{LOADED}) { # Case corrected by reload?
|
|
foreach my $i (keys %modules) {
|
|
if(uc($m) eq uc($i) && $modules{$i}{LOADED}) {
|
|
delete($modules{$m});
|
|
$m = $i;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $m;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
cmd_parseOpts($$$)
|
|
{
|
|
my ($def, $optRegexp, $res) = @_;
|
|
while($def) {
|
|
last if($def !~ m/^\s*($optRegexp)\s+/);
|
|
my $o = $1;
|
|
$def =~ s/^\s*$o\s+//;
|
|
$o =~ s/^-//;
|
|
$res->{$o} = 1;
|
|
}
|
|
return $def;
|
|
}
|
|
|
|
sub
|
|
CommandDefine($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
|
|
# ignoreErr ist used by RSS in fhem.cfg.demo, with no GD installed
|
|
# temporary #39610 #46640
|
|
# silent #57691
|
|
my %opt;
|
|
my $optRegexp = '-ignoreErr|-temporary|-silent';
|
|
$def = cmd_parseOpts($def, $optRegexp, \%opt);
|
|
my @a = split("[ \t]+", $def, 3);
|
|
|
|
my $name = $a[0];
|
|
return "Usage: define [$optRegexp] <name> <type> <type dependent arguments>"
|
|
if(int(@a) < 2);
|
|
return "$name already defined, delete it first" if(defined($defs{$name}));
|
|
return "Invalid characters in name (not A-Za-z0-9._): $name"
|
|
if(!goodDeviceName($name));
|
|
|
|
my $m = $a[1];
|
|
if(!$modules{$m}) { # Perhaps just wrong case?
|
|
foreach my $i (keys %modules) {
|
|
if(uc($m) eq uc($i)) {
|
|
$m = $i;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
my $newm = LoadModule($m, $opt{ignoreErr});
|
|
return "Cannot load module $m" if($newm eq "UNDEFINED");
|
|
$m = $newm;
|
|
|
|
return "Unknown module $m" if(!$modules{$m} || !$modules{$m}{DefFn});
|
|
|
|
my %hash;
|
|
|
|
$hash{NAME} = $name;
|
|
$hash{FUUID} = genUUID();
|
|
$hash{TYPE} = $m;
|
|
$hash{STATE} = "???";
|
|
$hash{DEF} = $a[2] if(int(@a) > 2);
|
|
#130588: start early after next save, for a small SubProcess size
|
|
$hash{NR} = ($modules{$m}{prioSave} && $devcountPrioSave < 30) ?
|
|
$devcountPrioSave++ :
|
|
($opt{temporary} ? $devcountTemp++ : $devcount++);
|
|
$hash{CFGFN} = $currcfgfile
|
|
if($currcfgfile ne AttrVal("global", "configfile", "") &&
|
|
!configDBUsed());
|
|
$hash{CL} = $cl;
|
|
$hash{TEMPORARY} = 1 if($opt{temporary});
|
|
|
|
# If the device wants to issue initialization gets/sets, then it needs to be
|
|
# in the global hash.
|
|
$defs{$name} = \%hash;
|
|
|
|
my $ret = CallFn($name, "DefFn", \%hash,
|
|
$modules{$m}->{parseParams} ? parseParams($def) : $def);
|
|
if($ret) {
|
|
Log 1, "define $def: $ret" if(!$opt{ignoreErr});
|
|
delete $defs{$name}; # Veto
|
|
delete $attr{$name};
|
|
|
|
} else {
|
|
delete $hash{CL};
|
|
foreach my $da (sort keys (%defaultattr)) { # Default attributes
|
|
CommandAttr($cl, "$name $da $defaultattr{$da}");
|
|
}
|
|
if($modules{$m}{NotifyFn} && !$hash{NTFY_ORDER}) {
|
|
$hash{NTFY_ORDER} = ($modules{$m}{NotifyOrderPrefix} ?
|
|
$modules{$m}{NotifyOrderPrefix} : "50-") . $name;
|
|
}
|
|
%ntfyHash = ();
|
|
if(!$opt{temporary} && $init_done) {
|
|
addStructChange("define", $name, $def) if(!$opt{silent});
|
|
DoTrigger("global", "DEFINED $name", 1);
|
|
}
|
|
|
|
if($init_done && $modules{$m}{Match}) { # reset multiple IOdev, #127565
|
|
foreach my $an (keys %defs) {
|
|
my $ah = $defs{$an};
|
|
my $cl = $ah->{Clients};
|
|
$cl = $modules{$ah->{TYPE}}{Clients} if(!$cl);
|
|
next if(!$cl || !$ah->{'.clientArray'});
|
|
foreach my $cmRe ( split(/:/, $cl) ) {
|
|
if($m =~ m/^$cmRe$/) {
|
|
delete($ah->{'.clientArray'});
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
}
|
|
return ($ret && $opt{ignoreErr} ?
|
|
"Cannot define $name, remove -ignoreErr for details" : $ret);
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandModify($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
|
|
my %opt;
|
|
$def = cmd_parseOpts($def, '-silent', \%opt);
|
|
my @a = split("[ \t]+", $def, 2);
|
|
|
|
return "Usage: modify <name> <type dependent arguments>"
|
|
if(int(@a) < 1);
|
|
|
|
# Return a list of modules
|
|
return "Define $a[0] first" if(!defined($defs{$a[0]}));
|
|
my $hash = $defs{$a[0]};
|
|
%ntfyHash = () if($hash->{NTFY_ORDER});
|
|
|
|
$hash->{OLDDEF} = $hash->{DEF};
|
|
$hash->{DEF} = $a[1];
|
|
$hash->{CL} = $cl;
|
|
my $ret = CallFn($a[0], "DefFn", $hash,
|
|
$modules{$hash->{TYPE}}->{parseParams} ?
|
|
parseParams("$a[0] $hash->{TYPE}".(defined($a[1]) ? " $a[1]":"")):
|
|
"$a[0] $hash->{TYPE}".(defined($a[1]) ? " $a[1]" : ""));
|
|
delete $hash->{CL};
|
|
if($ret) {
|
|
$hash->{DEF} = $hash->{OLDDEF};
|
|
} else {
|
|
addStructChange("modify", $a[0], $def) if(!$opt{silent});
|
|
DoTrigger("global", "MODIFIED $a[0]", 1) if($init_done);
|
|
}
|
|
|
|
delete($hash->{OLDDEF});
|
|
return $ret;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandDefMod($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
my %opt;
|
|
my $optRegexp = '-ignoreErr|-temporary|-silent';
|
|
$def = cmd_parseOpts($def, $optRegexp, \%opt);
|
|
my @a = split("[ \t]+", $def, 3);
|
|
|
|
return "Usage: defmod [$optRegexp] <name> <type> <type dependent arguments>"
|
|
if(int(@a) < 2);
|
|
if($defs{$a[0]}) {
|
|
$def = $a[2] ? "$a[0] $a[2]" : $a[0];
|
|
return "defmod $a[0]: Cannot change the TYPE of an existing definition"
|
|
if($a[1] ne $defs{$a[0]}{TYPE});
|
|
$def = "-".join(" -", keys %opt)." ".$def if(%opt);
|
|
return CommandModify($cl, $def);
|
|
} else {
|
|
$def = "-".join(" -", keys %opt)." ".$def if(%opt);
|
|
return CommandDefine($cl, $def);
|
|
}
|
|
}
|
|
|
|
#############
|
|
# internal
|
|
sub
|
|
fhem_setIoDev($$)
|
|
{
|
|
my ($hash, $val) = @_;
|
|
|
|
if(!$val || !defined($defs{$val})) {
|
|
if(!$init_done) {
|
|
$hash->{IODevMissing} = 1;
|
|
$hash->{IODevName} = $val;
|
|
}
|
|
return "unknown IODev $val specified";
|
|
}
|
|
|
|
my $av = AttrVal($hash->{NAME}, "IODev", "");
|
|
return "$hash->{NAME}: not setting IODev to $val, as different attr exists"
|
|
if($av && $av ne $val);
|
|
|
|
$hash->{IODev} = $defs{$val};
|
|
setReadingsVal($hash, "IODev", $val, TimeNow()); # 120603
|
|
delete($defs{$val}{".clientArray"}); # Force a recompute
|
|
delete($hash->{IODevMissing});
|
|
delete($hash->{IODevName});
|
|
return undef;
|
|
}
|
|
|
|
# Searches for a possible IODev, choosing the last defined compatible one.
|
|
sub
|
|
AssignIoPort($;$)
|
|
{
|
|
my ($hash, $proposed) = @_;
|
|
my $ht = $hash->{TYPE};
|
|
my $hn = $hash->{NAME};
|
|
|
|
$proposed = AttrVal($hn, "IODev", undef) if(!$proposed);
|
|
$proposed = ReadingsVal($hn, "IODev", undef) if(!$proposed);
|
|
|
|
if($proposed && $defs{$proposed} && IsDisabled($proposed) != 1) {
|
|
fhem_setIoDev($hash, $proposed);
|
|
|
|
} else {
|
|
# Set the I/O device, search for the last compatible one.
|
|
for my $p (sort { $defs{$b}{NR} <=> $defs{$a}{NR} } keys %defs) {
|
|
|
|
next if(IsDisabled($p) == 1);
|
|
next if($defs{$p}{TEMPORARY}); # e.g. server clients
|
|
my $cl = $defs{$p}{Clients};
|
|
$cl = $modules{$defs{$p}{TYPE}}{Clients} if(!$cl);
|
|
|
|
if($cl && $defs{$p}{NAME} ne $hn) { # e.g. RFR
|
|
my @fnd = grep { $hash->{TYPE} =~ m/^$_$/; } split(":", $cl);
|
|
if(@fnd) {
|
|
fhem_setIoDev($hash, $p);
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return if($hash->{IODev});
|
|
|
|
if($init_done) {
|
|
Log 3, "No I/O device found for $hn";
|
|
} else {
|
|
$hash->{IODevMissing} = 1;
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
|
|
#############
|
|
sub
|
|
CommandDelete($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
return "Usage: delete <name>$namedef\n" if(!$def);
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($def, $cl)) {
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first";
|
|
next;
|
|
}
|
|
|
|
$defs{$sdev}->{CL} = $cl;
|
|
my $ret = CallFn($sdev, "UndefFn", $defs{$sdev}, $sdev);
|
|
if($ret) {
|
|
push @rets, $ret;
|
|
delete $defs{$sdev}->{CL};
|
|
next;
|
|
}
|
|
$ret = CallFn($sdev, "DeleteFn", $defs{$sdev}, $sdev);
|
|
if($ret) {
|
|
push @rets, $ret;
|
|
delete $defs{$sdev}->{CL};
|
|
next;
|
|
}
|
|
delete $defs{$sdev}->{CL};
|
|
removeFromNtfyHash($sdev);
|
|
|
|
|
|
# Delete releated hashes
|
|
foreach my $p (keys %selectlist) {
|
|
if($selectlist{$p} && $selectlist{$p}{NAME} eq $sdev) {
|
|
delete $selectlist{$p};
|
|
}
|
|
}
|
|
foreach my $p (keys %readyfnlist) {
|
|
delete $readyfnlist{$p}
|
|
if($readyfnlist{$p} && $readyfnlist{$p}{NAME} eq $sdev);
|
|
}
|
|
|
|
my $temporary = $defs{$sdev}{TEMPORARY};
|
|
addStructChange("delete", $sdev, $sdev) if(!$temporary);
|
|
delete($attr{$sdev});
|
|
delete($defs{$sdev});
|
|
DoTrigger("global", "DELETED $sdev", 1) if(!$temporary);
|
|
|
|
}
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
#############
|
|
sub
|
|
CommandDeleteAttr($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
|
|
my $optRegexp = '-silent';
|
|
my %opt;
|
|
$def = cmd_parseOpts($def, $optRegexp, \%opt);
|
|
|
|
my @a = split(" ", $def, 2);
|
|
return "Usage: deleteattr <name> [<attrname>]\n$namedef" if(@a < 1);
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($a[0], $cl)) {
|
|
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first";
|
|
next;
|
|
}
|
|
|
|
$a[0] = $sdev;
|
|
|
|
if($a[1]) {
|
|
if($a[1] eq "userReadings") {
|
|
delete($defs{$sdev}{'.userReadings'});
|
|
} elsif($ra{$a[1]}) {
|
|
my $cache = $ra{$a[1]}{c};
|
|
delete $defs{$sdev}{$cache} if( $cache );
|
|
}
|
|
}
|
|
|
|
my $ret = CallFn($sdev, "AttrFn", "del", @a);
|
|
if($ret) {
|
|
push @rets, $ret;
|
|
next;
|
|
}
|
|
|
|
if(@a == 1) { # Delete all attributes of a device
|
|
delete($attr{$sdev});
|
|
|
|
} else { # delete specified attribute(s)
|
|
if(defined($attr{$sdev})) {
|
|
map { delete($attr{$sdev}{$_}) if($_ =~ m/^$a[1]$/) }
|
|
keys %{$attr{$sdev}};
|
|
}
|
|
|
|
}
|
|
addStructChange("deleteAttr", $sdev, join(" ", @a)) if(!$opt{silent});
|
|
DoTrigger("global", "DELETEATTR ".join(" ",@a), 1) if($init_done);
|
|
|
|
}
|
|
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
#############
|
|
sub
|
|
CommandDisplayAttr($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
|
|
my @a = split(" ", $def, 2);
|
|
return "Usage: displayattr <name> [<attrname>]\n$namedef" if(@a < 1);
|
|
|
|
my @rets;
|
|
my @devspec = devspec2array($a[0],$cl);
|
|
|
|
foreach my $sdev (@devspec) {
|
|
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first";
|
|
next;
|
|
}
|
|
|
|
my $ap = $attr{$sdev};
|
|
next if(!$ap);
|
|
my $d = (@devspec > 1 ? "$sdev " : "");
|
|
|
|
if(defined($a[1])) {
|
|
push @rets, "$d$ap->{$a[1]}" if(defined($ap->{$a[1]}));
|
|
|
|
} else {
|
|
push @rets, map { "$d$_ $ap->{$_}" } sort keys %{$ap};
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
#############
|
|
sub
|
|
CommandDeleteReading($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
|
|
my $quiet = undef;
|
|
if($def =~ m/^\s*-q\s(.*)$/) {
|
|
$quiet = 1;
|
|
$def = $1;
|
|
}
|
|
|
|
my @a = split(" ", $def, 3);
|
|
return "Usage: deletereading [-q] <name> <reading> [older-than-seconds]\n".
|
|
$namedef if(@a < 2);
|
|
|
|
eval { "" =~ m/$a[1]/ };
|
|
return "Bad regexp $a[1]: $@" if($@);
|
|
return "Bad older-than-seconds format $a[2]"
|
|
if(defined($a[2]) && $a[2] !~ m/^\d+$/);
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($a[0],$cl)) {
|
|
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first";
|
|
next;
|
|
}
|
|
|
|
$a[0] = $sdev;
|
|
my $readingspec= '^' . $a[1] . '$';
|
|
|
|
foreach my $reading (grep { /$readingspec/ }
|
|
keys %{$defs{$sdev}{READINGS}} ) {
|
|
next if(defined($a[2]) && ReadingsAge($sdev, $reading, 0) <= $a[2]);
|
|
readingsDelete($defs{$sdev}, $reading);
|
|
push @rets, "Deleted reading $reading for device $sdev";
|
|
}
|
|
|
|
}
|
|
return undef if($quiet);
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
sub
|
|
CommandSetReading($$)
|
|
{
|
|
my ($cl, $def) = @_;
|
|
my $timestamp;
|
|
|
|
if($def =~ m/^([^ ]+) +(\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d) +([^ ]+) +(.*)$/) {
|
|
$def = "$1 $3 $4";
|
|
$timestamp = $2;
|
|
}
|
|
|
|
my @a = split(" ", $def, 3);
|
|
return "Usage: setreading <name> [YYYY-MM-DD HH:MM:SS] <reading> <value>\n".
|
|
$namedef if(@a != 3);
|
|
|
|
my $err;
|
|
my @b = @a;
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($a[0],$cl)) {
|
|
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first";
|
|
next;
|
|
}
|
|
my $hash = $defs{$sdev};
|
|
if($featurelevel >= 5.7) {
|
|
$hash->{CL} = $cl;
|
|
($err, @b) = ReplaceSetMagic($hash, 3, @a);
|
|
delete $hash->{CL};
|
|
}
|
|
my $b1 = $b[1];
|
|
return "$sdev: bad reading name '$b1' (allowed chars: A-Za-z/\\d_\\.-)"
|
|
if(!goodReadingName($b1));
|
|
|
|
if($b1 eq "IODev") {
|
|
next if(!fhem_devSupportsAttr($sdev, "IODev"));
|
|
my $ret = fhem_setIoDev($hash, $b[2]);
|
|
push @rets, $ret if($ret);
|
|
next;
|
|
}
|
|
|
|
if($hash->{".updateTime"}) { # Called from userReadings, #110375
|
|
Log 1, "'setreading $def' called form userReadings is prohibited";
|
|
return;
|
|
} else {
|
|
readingsSingleUpdate($hash, $b1, $b[2], 1, $timestamp);
|
|
}
|
|
|
|
}
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
|
|
#############
|
|
sub
|
|
PrintHash($$)
|
|
{
|
|
my ($h, $lev) = @_;
|
|
my $si = AttrVal("global", "showInternalValues", 0);
|
|
return "" if($h->{".visited"});
|
|
$h->{".visited"} = 1;
|
|
|
|
my ($str,$sstr) = ("","");
|
|
foreach my $c (sort keys %{$h}) {
|
|
next if(!$si && $c =~ m/^\./ || $c eq ".visited");
|
|
if(ref($h->{$c})) {
|
|
if(ref($h->{$c}) eq "HASH") {
|
|
if(defined($h->{$c}{TIME}) && defined($h->{$c}{VAL})) {
|
|
$str .= sprintf("%*s %-19s %-15s %s\n",
|
|
$lev," ", $h->{$c}{TIME},$c,$h->{$c}{VAL});
|
|
} elsif($c eq "IODev" || $c eq "HASH") {
|
|
$str .= sprintf("%*s %-10s %s\n", $lev," ",$c, $h->{$c}{NAME});
|
|
|
|
} else {
|
|
$sstr .= sprintf("%*s %s:\n", $lev, " ", $c);
|
|
$sstr .= PrintHash($h->{$c}, $lev+2);
|
|
}
|
|
} elsif(ref($h->{$c}) eq "ARRAY") {
|
|
$sstr .= sprintf("%*s %s:\n", $lev, " ", $c);
|
|
foreach my $v (@{$h->{$c}}) {
|
|
$sstr .= sprintf("%*s %s\n",
|
|
$lev+2, " ", defined($v) ? $v:"undef");
|
|
}
|
|
}
|
|
} else {
|
|
my $v = $h->{$c};
|
|
$str .= sprintf("%*s %-10s %s\n",
|
|
$lev," ",$c, defined($v) ? $v : "");
|
|
}
|
|
}
|
|
delete $h->{".visited"};
|
|
return $str . $sstr;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandList($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my $str = "";
|
|
my %opt;
|
|
my $optRegexp = '-r|-R|-i';
|
|
$param = cmd_parseOpts($param, $optRegexp, \%opt);
|
|
|
|
if($opt{r} || $opt{R}) {
|
|
my @list;
|
|
if($opt{R}) {
|
|
return "-R needs a valid device as argument" if(!$param);
|
|
push @list, $param;
|
|
push @list, getPawList($param);
|
|
} else {
|
|
@list = devspec2array($param ? $param : ".*", $cl);
|
|
}
|
|
foreach my $d (@list) {
|
|
return "No device named $d found" if(!defined($defs{$d}));
|
|
$str .= "\n" if($str);
|
|
my @a = GetDefAndAttr($d);
|
|
$str .= join("\n", @a)."\n" if(@a);
|
|
if($opt{i}) {
|
|
my $intHash = PrintHash($defs{$d}, 2);
|
|
$intHash =~ s/\n/\n#/g;
|
|
$str .= "#".$intHash;
|
|
}
|
|
}
|
|
foreach my $d (sort @list) {
|
|
$str .= "\n" if($str);
|
|
my @a = GetAllReadings($d);
|
|
$str .= join("\n", @a)."\n" if(@a);
|
|
}
|
|
return $str;
|
|
}
|
|
|
|
if(!$param) { # List of all devices
|
|
|
|
$str = "\nType list <name> for detailed info.\n";
|
|
my $lt = "";
|
|
|
|
# Sort first by type then by name
|
|
for my $d (sort { my $x=$modules{$defs{$a}{TYPE}}{ORDER}.$defs{$a}{TYPE} cmp
|
|
$modules{$defs{$b}{TYPE}}{ORDER}.$defs{$b}{TYPE};
|
|
$x=($a cmp $b) if($x == 0); $x; } keys %defs) {
|
|
next if(IsIgnored($d) || ($cl && !Authorized($cl, "devicename", $d, 1)));
|
|
my $t = $defs{$d}{TYPE};
|
|
$str .= "\n$t:\n" if($t ne $lt);
|
|
$str .= sprintf(" %-20s (%s)\n", $d, $defs{$d}{STATE});
|
|
$lt = $t;
|
|
}
|
|
|
|
} else { # devspecArray
|
|
|
|
my @arg = split(" ", $param);
|
|
my @list = devspec2array($arg[0],$cl);
|
|
if($arg[1]) {
|
|
foreach my $sdev (@list) { # Show a Hash-Entry or Reading for each device
|
|
next if(!$defs{$sdev});
|
|
|
|
my $first = 1;
|
|
foreach my $n (@arg[1..@arg-1]) {
|
|
my $n = $n; # Forum #53223, for some perl versions $n is a reference
|
|
my $fType="";
|
|
if($n =~ m/^(.:)(.*$)/) {
|
|
$fType = $1;
|
|
$n = $2;
|
|
}
|
|
|
|
if(defined($defs{$sdev}{$n}) && (!$fType || $fType eq "i:")) {
|
|
my $val = $defs{$sdev}{$n};
|
|
if(ref($val) eq 'HASH') {
|
|
$val = ($val->{NAME} ? $val->{NAME} : # ???
|
|
join(" ", map { "$_=$val->{$_}" } sort keys %{$val}));
|
|
}
|
|
$str .= sprintf("%-20s %*s %*s %s\n", ($first++==1)?$sdev:'',
|
|
$arg[2]?19:0, '', $arg[2]?-15:0, $arg[2]?$n:'', $val);
|
|
|
|
} elsif($defs{$sdev}{READINGS} &&
|
|
defined($defs{$sdev}{READINGS}{$n})
|
|
&& (!$fType || $fType eq "r:")) {
|
|
$str .= sprintf("%-20s %s %*s %s\n", ($first++==1)?$sdev:'',
|
|
$defs{$sdev}{READINGS}{$n}{TIME},
|
|
$arg[2]?-15:0, $arg[2]?$n:'',
|
|
$defs{$sdev}{READINGS}{$n}{VAL});
|
|
|
|
} elsif($attr{$sdev} &&
|
|
defined($attr{$sdev}{$n})
|
|
&& (!$fType || $fType eq "a:")) {
|
|
$str .= sprintf("%-20s %*s %*s %s\n",($first++==1)?$sdev:'',
|
|
$arg[2]?19:0, '', $arg[2]?-15:0, $arg[2]?$n:'',
|
|
$attr{$sdev}{$n});
|
|
|
|
}
|
|
}
|
|
}
|
|
|
|
} elsif(@list == 1) { # Details
|
|
my $sdev = $list[0];
|
|
if(!defined($defs{$sdev})) {
|
|
$str .= "No device named $param found";
|
|
} else {
|
|
$str .= "Internals:\n";
|
|
$str .= PrintHash($defs{$sdev}, 2);
|
|
$str .= "Attributes:\n";
|
|
$str .= PrintHash($attr{$sdev}, 2);
|
|
}
|
|
|
|
} else {
|
|
foreach my $sdev (@list) { # List of devices
|
|
$str .= "$sdev\n";
|
|
}
|
|
|
|
}
|
|
}
|
|
|
|
return $str;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
CommandReload($$;$)
|
|
{
|
|
my ($cl, $param, $ignoreErr) = @_;
|
|
my %hash;
|
|
$param =~ s,/,,g;
|
|
$param =~ s,\.pm$,,g;
|
|
my $file = "$attr{global}{modpath}/FHEM/$param.pm";
|
|
my $cfgDB = '-';
|
|
if( ! -r "$file" ) {
|
|
if(configDBUsed()) {
|
|
# try to find the file in configDB
|
|
my $r = _cfgDB_Fileexport($file); # create file temporarily
|
|
return "Can't read $file from configDB." if ($r =~ m/^0/);
|
|
$cfgDB = 'X';
|
|
} else {
|
|
# configDB not used and file not found: it's a real error!
|
|
return "Can't read $file";
|
|
}
|
|
}
|
|
|
|
my $m = $param;
|
|
$m =~ s,^([0-9][0-9])_,,;
|
|
my $order = (defined($1) ? $1 : "00");
|
|
Log 5, "Loading $file";
|
|
|
|
no strict "refs";
|
|
my $ret = eval {
|
|
my $ret=do "$file";
|
|
unlink($file) if($cfgDB eq 'X'); # delete temp file
|
|
if(!$ret) {
|
|
Log 1, "reload: Error:Modul $param deactivated:\n $@" if(!$ignoreErr);
|
|
return $@;
|
|
}
|
|
|
|
# Get the name of the initialize function. This may differ from the
|
|
# filename as sometimes we live on a FAT fs with wrong case.
|
|
my $fnname = $m;
|
|
foreach my $i (keys %main::) {
|
|
if($i =~ m/^(${m})_initialize$/i) {
|
|
$fnname = $1;
|
|
last;
|
|
}
|
|
}
|
|
&{ "${fnname}_Initialize" }(\%hash);
|
|
$m = $fnname;
|
|
return undef;
|
|
};
|
|
use strict "refs";
|
|
|
|
return "$@" if($@);
|
|
return $ret if($ret);
|
|
|
|
my ($defptr, $ldata);
|
|
if($modules{$m}) {
|
|
$defptr = $modules{$m}{defptr};
|
|
$ldata = $modules{$m}{ldata};
|
|
}
|
|
$modules{$m} = \%hash;
|
|
$modules{$m}{ORDER} = $order;
|
|
$modules{$m}{LOADED} = 1;
|
|
$modules{$m}{defptr} = $defptr if($defptr);
|
|
$modules{$m}{ldata} = $ldata if($ldata);
|
|
|
|
return undef;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandRename($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my ($old, $new) = split(" ", $param);
|
|
|
|
return "old name is empty" if(!defined($old));
|
|
return "new name is empty" if(!defined($new));
|
|
|
|
return "Please define $old first" if(!defined($defs{$old}));
|
|
return "$new already defined" if(defined($defs{$new}));
|
|
return "Invalid characters in name (not A-Za-z0-9._): $new"
|
|
if(!goodDeviceName($new));
|
|
return "Cannot rename global" if($old eq "global");
|
|
return "Cannot rename $old from itself"
|
|
if($cl && $cl->{SNAME} && $cl->{SNAME} eq $old);
|
|
|
|
%ntfyHash = ();
|
|
$defs{$new} = $defs{$old};
|
|
$defs{$new}{NAME} = $new;
|
|
delete($defs{$old}); # The new pointer will preserve the hash
|
|
|
|
$attr{$new} = $attr{$old} if(defined($attr{$old}));
|
|
delete($attr{$old});
|
|
|
|
$oldvalue{$new} = $oldvalue{$old} if(defined($oldvalue{$old}));
|
|
delete($oldvalue{$old});
|
|
|
|
CallFn($new, "RenameFn", $new,$old);# ignore replies
|
|
for my $d (keys %defs) {
|
|
my $aw = ReadingsVal($d, "associatedWith", "");
|
|
next if($aw !~ m/\b$old\b/);
|
|
$aw =~ s/\b$old\b/$new/;
|
|
setReadingsVal($defs{$d}, "associatedWith", $aw, TimeNow()) if($defs{$d});
|
|
}
|
|
|
|
addStructChange("rename", $new, $param);
|
|
DoTrigger("global", "RENAMED $old $new", 1);
|
|
return undef;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
getAllAttr($;$$)
|
|
{
|
|
my ($d, $cl, $typeHash) = @_;
|
|
return "" if(!$defs{$d});
|
|
my $list = "";
|
|
|
|
my $add = sub($$)
|
|
{
|
|
my ($v,$type) = @_;
|
|
return if(!defined($v));
|
|
$list .= " " if($list);
|
|
$list .= $v;
|
|
map { s/:.*//;
|
|
$typeHash->{$_} = $attrSource{$_} ? $attrSource{$_} : $type }
|
|
split(" ",$v) if($typeHash);
|
|
};
|
|
|
|
&$add($AttrList, "framework");
|
|
if($defs{$d}{".AttrList"}) {
|
|
&$add($defs{$d}{".AttrList"}, "#".$defs{$d}{TYPE}); #124538
|
|
} else {
|
|
&$add($modules{$defs{$d}{TYPE}}{AttrList}, "#".$defs{$d}{TYPE});
|
|
}
|
|
|
|
my $nl2space = sub($$)
|
|
{
|
|
my ($v,$type) = @_;
|
|
return if(!defined($v));
|
|
$v =~ s/\n/ /g;
|
|
&$add($v, $type);
|
|
};
|
|
$nl2space->($attr{global}{userattr}, "global userattr");
|
|
$nl2space->($attr{$d}{userattr}, "device userattr") if($attr{$d});
|
|
return $list;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
getAllGets($;$)
|
|
{
|
|
my ($d, $cl) = @_;
|
|
|
|
my $a2 = CommandGet($cl, "$d ?");
|
|
return "" if($a2 !~ m/unknown.*choose one of /i);
|
|
$a2 =~ s/.*choose one of //;
|
|
return $a2;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
getAllSets($;$)
|
|
{
|
|
my ($d, $cl) = @_;
|
|
return "" if(!$defs{$d}); # Just safeguarding
|
|
|
|
if(AttrVal("global", "apiversion", 1)> 1) {
|
|
my @setters= getSetters($defs{$d});
|
|
return join(" ", @setters);
|
|
}
|
|
|
|
my $a2 = CommandSet($cl, "$d ?");
|
|
$a2 =~ s/.*choose one of //;
|
|
$a2 = "" if($a2 =~ /^No set implemented for/);
|
|
return "" if($a2 eq "");
|
|
|
|
$a2 = $defs{$d}{".eventMapCmd"}." $a2" if(defined($defs{$d}{".eventMapCmd"}));
|
|
return $a2;
|
|
}
|
|
|
|
sub
|
|
GlobalAttr($$$$)
|
|
{
|
|
my ($type, $me, $name, $val) = @_;
|
|
|
|
if($type eq "del") {
|
|
my %noDel = ( modpath=>1, verbose=>1, logfile=>1, configfile=>1, encoding=>1 );
|
|
return "The global attribute $name cannot be deleted" if($noDel{$name});
|
|
$featurelevel = 6.3 if($name eq "featurelevel");
|
|
$haveInet6 = 0 if($name eq "useInet6"); # IPv6
|
|
delete($defs{global}{ignoreRegexpObj}) if($name eq "ignoreRegexp");
|
|
return undef;
|
|
}
|
|
|
|
my $ev = $globalAttrFromEnv->{$name};
|
|
return "$name is readonly, it is set in the FHEM_GLOBALATTR environment"
|
|
if(defined($ev) && defined($val) && $ev ne $val);
|
|
|
|
|
|
################
|
|
if($name eq "logfile") {
|
|
my @t = localtime(gettimeofday());
|
|
my $ret = OpenLogfile(ResolveDateWildcards($val, @t));
|
|
if($ret) {
|
|
return $ret if($init_done);
|
|
die($ret);
|
|
}
|
|
}
|
|
|
|
if($name eq "encoding") { # Should be called from fhem.cfg/configDB
|
|
return "bad encoding parameter $val, good values are bytestream or unicode"
|
|
if($val ne "unicode" && $val ne "bytestream");
|
|
if($init_done) {
|
|
InternalTimer(0, sub {
|
|
CommandSave(undef, undef);
|
|
CommandShutdown(undef, "restart");
|
|
}, undef);
|
|
return;
|
|
}
|
|
$unicodeEncoding = ($val eq "unicode");
|
|
$currlogfile = "";
|
|
}
|
|
|
|
################
|
|
elsif($name eq "verbose") {
|
|
if($val =~ m/^[0-5]$/) {
|
|
return undef;
|
|
} else {
|
|
$attr{global}{verbose} = 3;
|
|
return "Valid value for verbose are 0,1,2,3,4,5";
|
|
}
|
|
}
|
|
|
|
elsif($name eq "modpath") {
|
|
return "modpath must point to a directory where the FHEM subdir is"
|
|
if(! -d "$val/FHEM");
|
|
my $modpath = $val;
|
|
my $modpath_FHEM = "$modpath/FHEM";
|
|
my $modpath_lib = "$modpath/lib";
|
|
|
|
opendir(DH, $modpath_FHEM) || return "Can't read $modpath_FHEM: $!";
|
|
|
|
unshift @INC, $modpath_FHEM if(!grep(/^\Q$modpath_FHEM\E$/,@INC));
|
|
unshift @INC, $modpath_lib if(!grep(/^\Q$modpath_lib\E$/, @INC));
|
|
unshift @INC, $modpath if(!grep(/^\Q$modpath\E$/, @INC)); #configDb
|
|
|
|
$cvsid =~ m/(fhem.pl) (\d+) (\d+-\d+-\d+)/;
|
|
$attr{global}{version} = "$1:$2/$3";
|
|
my $counter = 0;
|
|
my $oldVal = $attr{global}{modpath};
|
|
$attr{global}{modpath} = $modpath;
|
|
|
|
if(configDBUsed()) {
|
|
my $list = cfgDB_Read99(); # retrieve filelist from configDB
|
|
if($list) {
|
|
foreach my $m (split(/,/,$list)) {
|
|
$m =~ m/^([0-9][0-9])_(.*)\.pm$/;
|
|
CommandReload(undef, $m) if(!$modules{$2}{LOADED});
|
|
$counter++;
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach my $m (sort readdir(DH)) {
|
|
next if($m !~ m/^([0-9][0-9])_(.*)\.pm$/);
|
|
$modules{$2}{ORDER} = $1;
|
|
CommandReload(undef, $m) # Always load utility modules
|
|
if($1 eq "99" && !$modules{$2}{LOADED});
|
|
$counter++;
|
|
}
|
|
closedir(DH);
|
|
|
|
if(!$counter) {
|
|
$attr{global}{modpath} = $oldVal;
|
|
return "No modules found, set modpath to a directory in which a " .
|
|
"subdirectory called \"FHEM\" exists wich in turn contains " .
|
|
"the fhem module files <*>.pm";
|
|
}
|
|
|
|
|
|
}
|
|
elsif($name eq "featurelevel") {
|
|
return "$val is not in the form N.N" if($val !~ m/^\d+\.\d+$/);
|
|
$featurelevel = $val;
|
|
|
|
}
|
|
elsif($name eq "commandref" && $init_done) {
|
|
my $root = $attr{global}{modpath};
|
|
my $out = "";
|
|
$out = ">> $currlogfile 2>&1" if($currlogfile ne "-" && $^O ne "MSWin32");
|
|
if($val eq "full") {
|
|
system("$^X $root/contrib/commandref_join.pl -noWarnings $out")
|
|
} else {
|
|
system("$^X $root/contrib/commandref_modular.pl $out");
|
|
}
|
|
}
|
|
elsif($name eq "useInet6") {
|
|
if($val || !defined($val)) {
|
|
eval { require IO::Socket::INET6; require Socket6; };
|
|
return $@ if($@);
|
|
$haveInet6 = 1;
|
|
} else {
|
|
$haveInet6 = 0;
|
|
}
|
|
}
|
|
elsif($name eq "ignoreRegexp") {
|
|
return "Incorrect regexp (starts with *)" if($val =~ m/^\*/);
|
|
my $reObj;
|
|
eval { $reObj = qr/^$val$/; "Hallo" =~ $reObj ; };
|
|
return $@ if($@);
|
|
$defs{global}{ignoreRegexpObj} = $reObj;
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
sub
|
|
CommandAttr($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my ($ret, $append, $remove, @a);
|
|
my %opt;
|
|
my $optRegexp = '-a|-r|-silent';
|
|
$param = cmd_parseOpts($param, $optRegexp, \%opt);
|
|
|
|
@a = split(" ", $param, 3) if($param);
|
|
|
|
return "Usage: attr [$optRegexp] <name> <attrname> [<attrvalue>]\n$namedef"
|
|
if(@a < 2 || ($opt{a} && $opt{r}));
|
|
my $a1 = $a[1];
|
|
return "$a[0]: bad attribute name '$a1' (allowed chars: A-Za-z/\\d_\\.-)"
|
|
if($featurelevel > 5.9 && !goodReadingName($a1) && $a1 ne "?");
|
|
return "attr $param: attribute value is missing" if($#a < 2 && $a1 ne "?");
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($a[0], $a1 && $a1 eq "?" ? undef : $cl)) {
|
|
|
|
my $hash = $defs{$sdev};
|
|
my $attrName = $a1;
|
|
my $attrVal = $a[2];
|
|
if(!defined($hash)) {
|
|
push @rets, "Please define $sdev first" if($init_done);#define -ignoreErr
|
|
next;
|
|
}
|
|
|
|
my $list = getAllAttr($sdev);
|
|
if($attrName eq "?") {
|
|
push @rets, "$sdev: unknown attribute $attrName, choose one of $list";
|
|
next;
|
|
}
|
|
|
|
$attrName = resolveAttrRename($sdev,$attrName);
|
|
|
|
if(" $list " !~ m/ ${attrName}[ :;]/) {
|
|
my $found = 0;
|
|
foreach my $atr (split("[ \t]", $list)) { # is it a regexp?
|
|
$atr =~ /^([^;:]+)(:.*)?$/;
|
|
my $base = $1;
|
|
if(${attrName} =~ m/^$base$/) {
|
|
$found++;
|
|
last;
|
|
}
|
|
}
|
|
if(!$found) {
|
|
push @rets, "$sdev: unknown attribute $attrName. ".
|
|
"Type 'attr $sdev ?' for a detailed list.";
|
|
next;
|
|
}
|
|
}
|
|
|
|
if($opt{a} && $attr{$sdev} && $attr{$sdev}{$attrName}) {
|
|
$attrVal = $attr{$sdev}{$attrName} .
|
|
($attrVal =~ m/^,/ ? $attrVal : " $attrVal");
|
|
}
|
|
if($opt{r} && $attr{$sdev} && $attr{$sdev}{$attrName}) {
|
|
my $v = $attr{$sdev}{$attrName};
|
|
$v =~ s/\b$attrVal\b//;
|
|
$attrVal = $v;
|
|
}
|
|
|
|
if($attrName eq 'disable' && $attrVal eq 'toggle') {
|
|
$attrVal = IsDisabled($sdev) ? 0 : 1;
|
|
}
|
|
|
|
if($attrName eq "userReadings") {
|
|
|
|
my @userReadings;
|
|
# myReading1[:trigger1] [modifier1] { codecodecode1 }, ...
|
|
my $arg= $attrVal;
|
|
|
|
# matches myReading1[:trigger2] { codecode1 }
|
|
my $regexi= '\s*([\w.-]+)(:\S*)?\s+((\w+)\s+)?(\{.*?\})\s*';
|
|
my $regexo= '^(' . $regexi . ')(,\s*(.*))*$';
|
|
my $rNo=0;
|
|
|
|
while($arg =~ /$regexo/s) {
|
|
my $reading= $2;
|
|
my $trigger= $3 ? $3 : undef;
|
|
my $modifier= $5 ? $5 : "none";
|
|
my $perlCode= $6;
|
|
#Log 1, sprintf("userReading %s has perlCode %s with modifier %s%s",
|
|
# $userReading,$perlCode,$modifier,$trigger?" and trigger $trigger":"");
|
|
if(grep { /$modifier/ }
|
|
qw(none difference differential offset monotonic integral)) {
|
|
$trigger =~ s/^:// if($trigger);
|
|
my %userReading = ( reading => $reading,
|
|
trigger => $trigger,
|
|
modifier => $modifier,
|
|
perlCode => $perlCode );
|
|
push @userReadings, \%userReading;
|
|
} else {
|
|
push @rets, "$sdev: unknown modifier $modifier for ".
|
|
"userReading $reading, this userReading will be ignored";
|
|
}
|
|
$arg= defined($8) ? $8 : "";
|
|
}
|
|
$hash->{'.userReadings'}= \@userReadings;
|
|
}
|
|
|
|
my $oVal = ($attr{$sdev} ? $attr{$sdev}{$attrName} : "");
|
|
|
|
if($attrName eq "eventMap") {
|
|
delete $hash->{".eventMapHash"};
|
|
delete $hash->{".eventMapCmd"};
|
|
$attr{$sdev}{eventMap} = $attrVal;
|
|
my $r = ReplaceEventMap($sdev, "test", 1); # refresh eventMapCmd
|
|
if($r =~ m/^ERROR in eventMap for /) {
|
|
delete($attr{$sdev}{eventMap});
|
|
return $r;
|
|
}
|
|
}
|
|
|
|
if($ra{$attrName}) {
|
|
my ($lval,$rp,$cache) = ($attrVal, $ra{$attrName}{p}, $ra{$attrName}{c});
|
|
|
|
if($rp && $lval =~ m/$rp/s) {
|
|
my $err = perlSyntaxCheck($attrVal, %{$ra{$attrName}{pv}});
|
|
return "attr $sdev $attrName: $err" if($err);
|
|
|
|
} else {
|
|
delete $hash->{$cache} if( $cache );
|
|
|
|
my @a = split($ra{$attrName}{s}, $lval) ;
|
|
for my $v (@a) {
|
|
my $v = $v; # resolve the reference to avoid changing @a itself
|
|
if($ra{$attrName}{isNum}) {
|
|
my @va = split(":", $v);
|
|
return "attr $sdev $attrName $v: argument is not a number"
|
|
if(!defined($va[1]) || !looks_like_number($va[1]));
|
|
}
|
|
$v =~ s/$ra{$attrName}{r}// if($ra{$attrName}{r});
|
|
my $err ="Argument $v for attr $sdev $attrName is not a valid regexp";
|
|
return "$err: use .* instead of *" if($v =~ /^\*/); # no err in eval!?
|
|
eval { "Hallo" =~ m/^$v$/ };
|
|
return "$err: $@" if($@);
|
|
}
|
|
$hash->{$cache} = \@a if( $cache );
|
|
}
|
|
}
|
|
|
|
if($fhemdebug && $sdev eq "global") {
|
|
$attrVal = "-" if($attrName eq "logfile");
|
|
$attrVal = 5 if($attrName eq "verbose");
|
|
}
|
|
$defs{$sdev}->{CL} = $cl;
|
|
$ret = CallFn($sdev, "AttrFn", "set", $sdev, $attrName, $attrVal);
|
|
delete($defs{$sdev}->{CL});
|
|
if($ret) {
|
|
push @rets, $ret;
|
|
next;
|
|
}
|
|
|
|
$attr{$sdev}{$attrName} = $attrVal;
|
|
|
|
if($attrName eq "IODev") {
|
|
my $ret = fhem_setIoDev($hash, $attrVal);
|
|
if($ret) {
|
|
push @rets, $ret if($init_done);
|
|
next;
|
|
}
|
|
}
|
|
|
|
if($attrName eq "stateFormat" && $init_done) {
|
|
my $err = perlSyntaxCheck($attrVal, ("%name"=>""));
|
|
return $err if($err);
|
|
evalStateFormat($hash);
|
|
}
|
|
addStructChange("attr", $sdev, "$sdev $attrName $attrVal")
|
|
if(!$opt{silent} && (!defined($oVal) || $oVal ne $attrVal));
|
|
DoTrigger("global", "ATTR $sdev $attrName $attrVal", 1) if($init_done);
|
|
|
|
}
|
|
|
|
Log 3, join(" ", @rets) if(!$cl && @rets);
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
|
|
#####################################
|
|
# Default Attr
|
|
sub
|
|
CommandDefaultAttr($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
|
|
my @a = split(" ", $param, 2);
|
|
if(int(@a) == 0) {
|
|
%defaultattr = ();
|
|
} elsif(int(@a) == 1) {
|
|
$defaultattr{$a[0]} = 1;
|
|
} else {
|
|
$defaultattr{$a[0]} = $a[1];
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandSetstate($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
|
|
my @a = split(" ", $param, 2);
|
|
my $addMsg = ($init_done ? "" : "Bogus command was: setstate $param");
|
|
return "Usage: setstate <name> <state>\n${namedef}$addMsg" if(@a != 2);
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($a[0],$cl)) {
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first" if($init_done); # 115934
|
|
next;
|
|
}
|
|
|
|
my $d = $defs{$sdev};
|
|
|
|
# Detailed state with timestamp
|
|
if($a[1] =~ m/^(\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}) +([^ ].*)$/s) {
|
|
my ($tim, $nameval) = ($1, $2);
|
|
my ($sname, $sval) = split(" ", $nameval, 2);
|
|
$sval = "" if(!defined($sval));
|
|
my $ret = CallFn($sdev, "StateFn", $d, $tim, $sname, $sval);
|
|
if($ret) {
|
|
push @rets, $ret;
|
|
next;
|
|
}
|
|
|
|
if($sname eq "IODev") {
|
|
next if(!fhem_devSupportsAttr($sdev, "IODev"));
|
|
my $ret = fhem_setIoDev($d, $sval);
|
|
if($ret) {
|
|
push @rets, $ret if($init_done);
|
|
next;
|
|
}
|
|
}
|
|
|
|
Log3 $d, 3,
|
|
"$sdev: bad reading name '$sname' (allowed chars: A-Za-z/\\d_\\.-)"
|
|
if(!goodReadingName($sname));
|
|
|
|
if(!defined($d->{READINGS}{$sname}) ||
|
|
!defined($d->{READINGS}{$sname}{TIME}) ||
|
|
$d->{READINGS}{$sname}{TIME} lt $tim) {
|
|
setReadingsVal($d, $sname, $sval, $tim);
|
|
}
|
|
|
|
|
|
} else {
|
|
|
|
# The timestamp is not the correct one, but we do not store a timestamp
|
|
# for this reading.
|
|
my $tn = TimeNow();
|
|
$a[1] =~ s/\\(...)/chr(oct($1))/ge if($a[1] =~ m/^(\\011|\\040)+$/);
|
|
$oldvalue{$sdev}{TIME} = $tn;
|
|
$oldvalue{$sdev}{VAL} = ($init_done ? $d->{STATE} : $a[1]);
|
|
|
|
# Do not overwrite state like "opened" or "initialized"
|
|
$d->{STATE} = $a[1] if($init_done || $d->{STATE} eq "???");
|
|
my $ret = CallFn($sdev, "StateFn", $d, $tn, "STATE", $a[1]);
|
|
if($ret) {
|
|
push @rets, $ret;
|
|
next;
|
|
}
|
|
|
|
}
|
|
}
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
CommandTrigger($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
|
|
my ($dev, $state) = split(" ", $param, 2);
|
|
return "Usage: trigger <name> <state>\n$namedef" if(!$dev);
|
|
$state = "" if(!defined($state));
|
|
|
|
my @rets;
|
|
foreach my $sdev (devspec2array($dev,$cl)) {
|
|
if(!defined($defs{$sdev})) {
|
|
push @rets, "Please define $sdev first";
|
|
next;
|
|
}
|
|
my $ret = DoTrigger($sdev, $state);
|
|
if($ret) {
|
|
push @rets, $ret;
|
|
next;
|
|
}
|
|
}
|
|
return join("\n", @rets);
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
sleep_WakeUpFn($)
|
|
{
|
|
my $id = shift;
|
|
my $h = $sleepers{$id};
|
|
return if(!$h);
|
|
delete $sleepers{$id};
|
|
CommandDelete($h->{cl}, $h->{name}) if(!defined($h->{sec}));
|
|
|
|
$evalSpecials = $h->{evalSpecials};
|
|
my $ret = AnalyzeCommandChain($h->{cl}, $h->{cmd});
|
|
Log 2, "After sleep: $ret" if($ret && !$h->{quiet});
|
|
}
|
|
|
|
sub
|
|
CommandCancel($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my ($id, $quiet) = split(" ", $param, 3);
|
|
return "Last parameter must be quiet" if($quiet && $quiet ne "quiet");
|
|
|
|
if( !$id ) {
|
|
my $ret;
|
|
foreach $id (sort keys %sleepers) {
|
|
my $h = $sleepers{$id};
|
|
$ret .= "\n" if( $ret );
|
|
$ret .= sprintf( "%-12s %-19s %s", $id, $h->{till}, $h->{cmd} );
|
|
}
|
|
$ret = "no pending sleeps" if(!$ret);
|
|
return $ret;
|
|
|
|
} elsif( my $h = $sleepers{$id} ) {
|
|
RemoveInternalTimer($id, "sleep_WakeUpFn") if(defined($h->{sec}));
|
|
CommandDelete($cl, $h->{name}) if(!defined($h->{sec}));
|
|
delete $sleepers{$id};
|
|
|
|
} else {
|
|
return "no such id: $id" if( !$quiet );
|
|
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
sub
|
|
CommandSleep($$)
|
|
{
|
|
my ($cl, $param) = @_;
|
|
my ($sec, $id, $quiet) = split(" ", $param, 3);
|
|
if( $id && $id eq 'quiet' ) {
|
|
$quiet = $id;
|
|
$id = undef;
|
|
}
|
|
return "Argument missing" if(!defined($sec));
|
|
return "Last parameter must be quiet" if($quiet && $quiet ne "quiet");
|
|
|
|
my $name = ".sleep_".(++$intAtCnt);
|
|
$id = $name if(!$id);
|
|
|
|
my $till;
|
|
if($sec !~ m/^[0-9\.]+$/) {
|
|
my ($err, $hr,$min,$s, $fn) = GetTimeSpec($sec);
|
|
if($err) { # not a valid timespec => treat as regex
|
|
if(@cmdList && $init_done) {
|
|
CommandDelete($cl, $sleepers{$id}{name}) if($sleepers{$id});
|
|
$err = CommandDefine($cl,
|
|
"-temporary $name notify $sec {sleep_WakeUpFn('$id')}");
|
|
$attr{$name}{ignore} = 1;
|
|
return $err if($err);
|
|
}
|
|
$till = $sec;
|
|
$sec = undef;
|
|
|
|
} else {
|
|
$sec = 3600*$hr+60*$min+$s;
|
|
|
|
}
|
|
}
|
|
$till = gettimeofday()+$sec if(defined($sec));
|
|
|
|
if(@cmdList && $init_done) {
|
|
my %h = (cmd => join(";", @cmdList),
|
|
evalSpecials => $evalSpecials,
|
|
quiet => $quiet,
|
|
till => defined($sec) ? FmtDateTime($till) : $till,
|
|
sec => $sec,
|
|
name => $name,
|
|
cl => $cl,
|
|
id => $id);
|
|
if(defined($sec)) {
|
|
RemoveInternalTimer($id, "sleep_WakeUpFn");
|
|
InternalTimer($till, "sleep_WakeUpFn", $id, 0);
|
|
}
|
|
$sleepers{$id} = \%h;
|
|
@cmdList=();
|
|
|
|
} else {
|
|
Log 1,
|
|
"WARNING: sleep without additional commands is deprecated and blocks FHEM";
|
|
select(undef, undef, undef, $sec);
|
|
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
#####################################
|
|
# Add a function to be executed after select returns. Only one function is
|
|
# executed after select returns.
|
|
# fn: a function reference
|
|
# arg: function argument
|
|
# nice: a number like in unix "nice". Smaller numbers mean higher priority.
|
|
# limited to [-20,19], default 0
|
|
# returns the number of elements in the corrsponding queue
|
|
sub
|
|
PrioQueue_add($$;$)
|
|
{
|
|
my ($fn, $arg, $nice) = @_;
|
|
|
|
$nice = 0 if(!defined($nice) || !looks_like_number($nice));
|
|
$nice = -20 if($nice <-20);
|
|
$nice = 19 if($nice > 19);
|
|
$nextat = 1;
|
|
$prioQueues{$nice} = [] if(!defined $prioQueues{$nice});
|
|
push(@{$prioQueues{$nice}},{fn=>$fn, arg=>$arg});
|
|
};
|
|
|
|
|
|
#####################################
|
|
# Return the time to the next event (or undef if there is none)
|
|
# and call each function which was scheduled for this time
|
|
sub
|
|
HandleTimeout()
|
|
{
|
|
return undef if(!$nextat);
|
|
|
|
my $now = gettimeofday();
|
|
if($now < $nextat) {
|
|
$selectTimestamp = $now;
|
|
return ($nextat-$now);
|
|
}
|
|
|
|
$nextat = 0;
|
|
while(@intAtA) {
|
|
my $at = $intAtA[0];
|
|
my $tim = $at->{TRIGGERTIME};
|
|
if($tim && $tim > $now) {
|
|
$nextat = $tim;
|
|
last;
|
|
}
|
|
delete $intAt{$at->{atNr}} if($at->{atNr});
|
|
shift(@intAtA);
|
|
|
|
if($tim && $at->{FN}) {
|
|
no strict "refs";
|
|
&{$at->{FN}}($at->{ARG});
|
|
use strict "refs";
|
|
}
|
|
}
|
|
|
|
if(%prioQueues) {
|
|
my $nice = minNum(keys %prioQueues);
|
|
my $entry = shift(@{$prioQueues{$nice}});
|
|
delete $prioQueues{$nice} if(!@{$prioQueues{$nice}});
|
|
&{$entry->{fn}}($entry->{arg});
|
|
$nextat = 1 if(%prioQueues);
|
|
}
|
|
|
|
if(!$nextat) {
|
|
$selectTimestamp = $now;
|
|
return undef;
|
|
}
|
|
|
|
$now = gettimeofday(); # if some callbacks took longer
|
|
$selectTimestamp = $now;
|
|
|
|
return ($now < $nextat) ? ($nextat-$now) : 0;
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
InternalTimer($$$;$)
|
|
{
|
|
my ($tim, $fn, $arg, $waitIfInitNotDone) = @_;
|
|
|
|
$tim = 1 if(!$tim);
|
|
if(!$init_done && $waitIfInitNotDone) {
|
|
select(undef, undef, undef, $tim-gettimeofday());
|
|
no strict "refs";
|
|
&{$fn}($arg);
|
|
use strict "refs";
|
|
return;
|
|
}
|
|
|
|
$nextat = $tim if(!$nextat || $nextat > $tim);
|
|
my %h = (TRIGGERTIME=>$tim, FN=>$fn, ARG=>$arg, atNr=>++$intAtCnt);
|
|
$h{STACKTRACE} = stacktraceAsString(1) if($addTimerStacktrace);
|
|
$intAt{$h{atNr}} = \%h;
|
|
|
|
if(!@intAtA) {
|
|
push @intAtA, \%h;
|
|
return;
|
|
}
|
|
|
|
my $idx = $#intAtA; # binary insert
|
|
my ($lowerIdx,$upperIdx) = (0, $idx);
|
|
while($lowerIdx <= $upperIdx) {
|
|
$idx = int(($upperIdx-$lowerIdx)/2)+$lowerIdx;
|
|
if($tim >= $intAtA[$idx]->{TRIGGERTIME}) {
|
|
$lowerIdx = ++$idx;
|
|
} else {
|
|
$upperIdx = $idx-1;
|
|
}
|
|
}
|
|
splice(@intAtA, $idx, 0, \%h);
|
|
}
|
|
|
|
sub
|
|
RemoveInternalTimer($;$)
|
|
{
|
|
my ($arg, $fn) = @_;
|
|
return if(!$arg && !$fn);
|
|
|
|
for(my $i=0; $i<@intAtA; $i++) {
|
|
my ($ia, $if) = ($intAtA[$i]->{ARG}, $intAtA[$i]->{FN});
|
|
if((!$arg || ($ia && $ia eq $arg)) &&
|
|
(!$fn || ($if && $if eq $fn))) {
|
|
my $t = $intAtA[$i]->{atNr};
|
|
delete $intAt{$t} if($intAt{$t});
|
|
splice @intAtA, $i, 1;
|
|
$i--;
|
|
}
|
|
}
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
stacktrace()
|
|
{
|
|
my $i = 1;
|
|
my $max_depth = 50;
|
|
|
|
# Forum #59831
|
|
Log 1, "eval: $cmdFromAnalyze"
|
|
if($cmdFromAnalyze && $attr{global}{verbose} < 3);
|
|
Log 1, "stacktrace:";
|
|
while( (my @call_details = (caller($i++))) && ($i<$max_depth) ) {
|
|
Log 1, sprintf (" %-35s called by %s (%s)",
|
|
$call_details[3], $call_details[1], $call_details[2]);
|
|
}
|
|
}
|
|
|
|
sub
|
|
stacktraceAsString($)
|
|
{
|
|
my ($offset) = @_;
|
|
$offset = 1 if (!$offset);
|
|
my ($max_depth,$ret) = (50,"");
|
|
|
|
while( (my @call_details = (caller($offset++))) && ($offset<$max_depth) ) {
|
|
$call_details[3] =~ s/main:://;
|
|
$ret .= sprintf(" %s:%s", $call_details[3], $call_details[2]);
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
my $inWarnSub;
|
|
|
|
sub
|
|
SignalHandling()
|
|
{
|
|
if($^O ne "MSWin32") {
|
|
$SIG{TERM} = sub { $gotSig = "TERM"; };
|
|
$SIG{USR1} = sub { $gotSig = "USR1"; };
|
|
$SIG{PIPE} = 'IGNORE';
|
|
$SIG{CHLD} = 'IGNORE';
|
|
$SIG{HUP} = sub { $gotSig = "HUP"; };
|
|
$SIG{ALRM} = sub { Log 1, "ALARM signal, blocking write?" };
|
|
#$SIG{'XFSZ'} = sub { Log 1, "XFSZ signal" }; # to test with limit filesize
|
|
}
|
|
$SIG{__WARN__} = sub {
|
|
my ($msg) = @_;
|
|
|
|
return if($inWarnSub);
|
|
$lastWarningMsg = $msg;
|
|
if(!$attr{global}{stacktrace} && $data{WARNING}{$msg}) {
|
|
$data{WARNING}{$msg}++;
|
|
return;
|
|
}
|
|
$inWarnSub = 1;
|
|
$data{WARNING}{$msg}++;
|
|
chomp($msg);
|
|
Log 1, "PERL WARNING: $msg";
|
|
Log 3, "eval: $cmdFromAnalyze" if($cmdFromAnalyze);
|
|
stacktrace() if($attr{global}{stacktrace} &&
|
|
$msg !~ m/ redefined at /);
|
|
$inWarnSub = 0;
|
|
};
|
|
# $SIG{__DIE__} = sub {...} #Removed. Forum #35796
|
|
}
|
|
|
|
|
|
#####################################
|
|
sub
|
|
TimeNow()
|
|
{
|
|
return FmtDateTime(gettimeofday());
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
FmtDateTime($)
|
|
{
|
|
my @t = localtime(shift);
|
|
return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
|
|
$t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]);
|
|
}
|
|
|
|
sub
|
|
FmtTime($)
|
|
{
|
|
my @t = localtime(shift);
|
|
return sprintf("%02d:%02d:%02d", $t[2], $t[1], $t[0]);
|
|
}
|
|
|
|
sub
|
|
FmtDateTimeRFC1123($)
|
|
{
|
|
my $t = gmtime(shift);
|
|
if($t =~ m/^(...) (...) (..) (..:..:..) (....)$/) {
|
|
return sprintf("$1, %02d $2 $5 $4 GMT", $3);
|
|
}
|
|
return $t;
|
|
}
|
|
|
|
|
|
sub
|
|
Logdir()
|
|
{
|
|
return AttrVal("global","logdir", AttrVal("global","modpath","")."/log");
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
ResolveDateWildcards($@)
|
|
{
|
|
use POSIX qw(strftime);
|
|
|
|
my ($f, @t) = @_;
|
|
return $f if(!$f);
|
|
return $f if($f !~ m/%/); # Be fast if there is no wildcard
|
|
my $logdir = Logdir();
|
|
$f =~ s/%L/$logdir/g;
|
|
my $ret = strftime($f,@t); # converts from UTF-8 to WideChar
|
|
$ret = Encode::encode("UTF-8", $ret) if(!$unicodeEncoding);
|
|
return $ret;
|
|
}
|
|
|
|
sub
|
|
SemicolonEscape($)
|
|
{
|
|
my $cmd = shift;
|
|
$cmd =~ s/^[ \t]*//;
|
|
$cmd =~ s/[ \t]*$//;
|
|
if($cmd =~ m/^{.*}$/s || $cmd =~ m/^".*"$/s) {
|
|
$cmd =~ s/;/;;/g
|
|
}
|
|
return $cmd;
|
|
}
|
|
|
|
sub
|
|
EvalSpecials($%)
|
|
{
|
|
# $NAME will be replaced with the device name which generated the event
|
|
# $EVENT will be replaced with the whole event string
|
|
# $EVTPART<N> will be replaced with single words of an event
|
|
my ($exec, %specials)= @_;
|
|
if($specials{__UNIQUECMD__}) {
|
|
delete $specials{__UNIQUECMD__};
|
|
} else {
|
|
$exec = SemicolonEscape($exec);
|
|
}
|
|
|
|
my $idx = 0;
|
|
if(defined($specials{"%EVENT"})) {
|
|
foreach my $part (split(" ", $specials{"%EVENT"})) {
|
|
$specials{"%EVTPART$idx"} = $part;
|
|
last if($idx >= 20);
|
|
$idx++;
|
|
}
|
|
}
|
|
|
|
if($featurelevel > 5.6) {
|
|
$evalSpecials = \%specials;
|
|
return $exec;
|
|
}
|
|
|
|
# featurelevel <= 5.6 only:
|
|
# The character % will be replaced with the received event,
|
|
# e.g. with on or off or measured-temp: 21.7 (Celsius)
|
|
# The character @ will be replaced with the device name.
|
|
# To use % or @ in the text itself, use the double mode (%% or @@).
|
|
|
|
my $re = join("|", keys %specials); # Found the $syntax, skip the rest
|
|
$re =~ s/%//g;
|
|
if($exec =~ m/\$($re)\b/) {
|
|
$evalSpecials = \%specials;
|
|
return $exec;
|
|
}
|
|
|
|
$exec =~ s/%%/____/g;
|
|
|
|
# perform macro substitution
|
|
my $extsyntax= 0;
|
|
foreach my $special (keys %specials) {
|
|
$extsyntax+= ($exec =~ s/$special/$specials{$special}/g);
|
|
}
|
|
|
|
if(!$extsyntax) {
|
|
$exec =~ s/%/$specials{"%EVENT"}/g;
|
|
}
|
|
$exec =~ s/____/%/g;
|
|
|
|
$exec =~ s/@@/____/g;
|
|
$exec =~ s/@/$specials{"%NAME"}/g;
|
|
$exec =~ s/____/@/g;
|
|
|
|
return $exec;
|
|
}
|
|
|
|
#####################################
|
|
# Parse a timespec: HH:MM:SS, HH:MM or { perfunc() }
|
|
sub
|
|
GetTimeSpec($)
|
|
{
|
|
my ($tspec) = @_;
|
|
my ($hr, $min, $sec, $fn);
|
|
|
|
if($tspec =~ m/^([0-9]+):([0-5][0-9]):([0-5][0-9])$/) { # HH:MM:SS
|
|
($hr, $min, $sec) = ($1, $2, $3);
|
|
|
|
} elsif($tspec =~ m/^([0-9]+):([0-5][0-9])$/) { # HH:MM
|
|
($hr, $min, $sec) = ($1, $2, 0);
|
|
|
|
} elsif($tspec =~ m/^{(.*)}$/) { # {function}
|
|
$fn = $1;
|
|
$tspec = AnalyzeCommand(undef, "{$fn}");
|
|
$tspec = "<empty string>" if(!$tspec);
|
|
my ($err, $fn2);
|
|
($err, $hr, $min, $sec, $fn2) = GetTimeSpec($tspec);
|
|
return ("the function \"$fn\" must return a timespec and not $tspec.",
|
|
undef, undef, undef, $tspec) if($err);
|
|
|
|
} else {
|
|
return ("Wrong timespec $tspec: either HH:MM:SS or {perlcode}",
|
|
undef, undef, undef, undef);
|
|
}
|
|
return (undef, $hr, $min, $sec, $fn);
|
|
}
|
|
|
|
|
|
sub
|
|
deviceEvents($$)
|
|
{
|
|
my ($hash, $withState) = @_; # withState returns stateEvent as state:event
|
|
|
|
return undef if(!$hash || !$hash->{CHANGED});
|
|
|
|
if($withState) {
|
|
my $cws = $hash->{CHANGEDWITHSTATE};
|
|
if(defined($cws)){
|
|
if(int(@{$cws}) == 0) {
|
|
if($hash->{READINGS} && $hash->{READINGS}{state}) {
|
|
my $ostate = $hash->{READINGS}{state}{VAL};
|
|
my $mstate = ReplaceEventMap($hash->{NAME}, $ostate, 1);
|
|
@{$cws} = map { $_ eq $mstate ? "state: $ostate" : $_ }
|
|
@{$hash->{CHANGED}};
|
|
} else {
|
|
@{$cws} = @{$hash->{CHANGED}};
|
|
}
|
|
}
|
|
return $cws;
|
|
}
|
|
}
|
|
return $hash->{CHANGED};
|
|
}
|
|
|
|
#####################################
|
|
# Do the notification
|
|
sub
|
|
DoTrigger($$@)
|
|
{
|
|
my ($dev, $newState, $noreplace) = @_;
|
|
my $ret = "";
|
|
my $hash = $defs{$dev};
|
|
return "" if(!defined($hash));
|
|
|
|
$hash->{".triggerUsed"} = 1 if(defined($hash->{".triggerUsed"}));
|
|
if(defined($newState)) {
|
|
if($hash->{CHANGED}) {
|
|
push @{$hash->{CHANGED}}, $newState;
|
|
} else {
|
|
$hash->{CHANGED}[0] = $newState;
|
|
}
|
|
} elsif(!defined($hash->{CHANGED})) {
|
|
return "";
|
|
}
|
|
|
|
if(!$noreplace) { # Backward compatibility for code without readingsUpdate
|
|
if($attr{$dev}{eventMap}) {
|
|
my $c = $hash->{CHANGED};
|
|
for(my $i = 0; $i < @{$c}; $i++) {
|
|
$c->[$i] = ReplaceEventMap($dev, $c->[$i], 1);
|
|
}
|
|
$hash->{STATE} = ReplaceEventMap($dev, $hash->{STATE}, 1);
|
|
}
|
|
}
|
|
|
|
my $max = int(@{$hash->{CHANGED}});
|
|
if(AttrVal($dev, "do_not_notify", 0)) {
|
|
delete($hash->{CHANGED});
|
|
delete($hash->{CHANGETIME});
|
|
delete($hash->{CHANGEDWITHSTATE});
|
|
return "";
|
|
}
|
|
my $now = TimeNow();
|
|
|
|
################
|
|
# Log/notify modules
|
|
# If modifying a device in its own trigger, do not call the triggers from
|
|
# the inner loop.
|
|
if($max && !defined($hash->{INTRIGGER})) {
|
|
$hash->{INTRIGGER}=1;
|
|
$hash->{eventCount}++;
|
|
if($attr{global}{verbose} >= 5) {
|
|
Log 5, "Starting notify loop for $dev, " . scalar(@{$hash->{CHANGED}}) .
|
|
" event(s), first is " . escapeLogLine($hash->{CHANGED}->[0]);
|
|
}
|
|
createNtfyHash() if(!%ntfyHash);
|
|
$hash->{NTFY_TRIGGERTIME} = $now; # Optimize FileLog
|
|
my $ntfyLst = (defined($ntfyHash{$dev}) ? $ntfyHash{$dev} : $ntfyHash{"*"});
|
|
foreach my $n (@{$ntfyLst}) {
|
|
next if(!defined($defs{$n})); # Was deleted in a previous notify
|
|
my $r = CallFn($n, "NotifyFn", $defs{$n}, $hash);
|
|
$ret .= " $n:$r" if($r);
|
|
}
|
|
delete($hash->{NTFY_TRIGGERTIME});
|
|
Log 5, "End notify loop for $dev";
|
|
|
|
################
|
|
# Inform
|
|
if($hash->{CHANGED}) { # It gets deleted sometimes (?)
|
|
my $tn = $now;
|
|
if($attr{global}{mseclog}) {
|
|
my ($seconds, $microseconds) = gettimeofday();
|
|
$tn .= sprintf(".%03d", $microseconds/1000);
|
|
}
|
|
my $ct = $hash->{CHANGETIME};
|
|
foreach my $c (keys %inform) {
|
|
my $dc = $defs{$c};
|
|
if(!$dc || $dc->{NR} != $inform{$c}{NR}) {
|
|
delete($inform{$c});
|
|
next;
|
|
}
|
|
next if($inform{$c}{type} eq "raw");
|
|
my $re = $inform{$c}{regexp};
|
|
my $events = deviceEvents($hash, $inform{$c}{type} =~ m/WithState/);
|
|
$max = int(@{$events});
|
|
for(my $i = 0; $i < $max; $i++) {
|
|
my $event = $events->[$i];
|
|
my $t = (($ct && $ct->[$i]) ? $ct->[$i] : $tn);
|
|
next if($re && !($dev =~ m/$re/ || "$dev:$event" =~ m/$re/));
|
|
|
|
my $txt = ($inform{$c}{type} eq "timer" ? "$t " : "").
|
|
"$hash->{TYPE} $dev $event\n";
|
|
my $enc = $dc->{encoding} &&
|
|
$dc->{encoding} eq "latin1" ? "Latin1":"UTF-8";
|
|
$txt = Encode::encode($enc, $txt) if($unicodeEncoding);
|
|
addToWritebuffer($dc, $txt);
|
|
}
|
|
}
|
|
}
|
|
|
|
delete($hash->{INTRIGGER});
|
|
}
|
|
|
|
|
|
####################
|
|
# Used by triggered perl programs to check the old value
|
|
# Not suited for multi-valued devices (KS300, etc)
|
|
$oldvalue{$dev}{TIME} = $now;
|
|
$oldvalue{$dev}{VAL} = $hash->{STATE};
|
|
|
|
if(!defined($hash->{INTRIGGER})) {
|
|
delete($hash->{CHANGED});
|
|
delete($hash->{CHANGETIME});
|
|
delete($hash->{CHANGEDWITHSTATE});
|
|
}
|
|
|
|
Log 3, "NTFY return: $ret" if($ret);
|
|
|
|
return $ret;
|
|
}
|
|
|
|
#####################################
|
|
# Wrapper for calling a module function
|
|
sub
|
|
CallFn(@)
|
|
{
|
|
my $d = shift;
|
|
my $n = shift;
|
|
|
|
if(!$d || !$defs{$d}) {
|
|
$d = "<undefined>" if(!defined($d));
|
|
Log 0, "Strange call for nonexistent $d: $n";
|
|
stacktrace();
|
|
return undef;
|
|
}
|
|
if(!$defs{$d}{TYPE}) {
|
|
Log 0, "Strange call for typeless $d: $n";
|
|
return undef;
|
|
}
|
|
my $fn = $modules{$defs{$d}{TYPE}}{$n};
|
|
return "" if(!$fn);
|
|
if(wantarray) {
|
|
no strict "refs";
|
|
my @ret = &{$fn}(@_);
|
|
use strict "refs";
|
|
return @ret;
|
|
} else {
|
|
no strict "refs";
|
|
my $ret = &{$fn}(@_);
|
|
use strict "refs";
|
|
return $ret;
|
|
}
|
|
}
|
|
|
|
#####################################
|
|
# Alternative to CallFn with optional functions in $defs, Forum #64741
|
|
sub
|
|
CallInstanceFn(@)
|
|
{
|
|
my $d = shift;
|
|
my $n = shift;
|
|
|
|
if(!$d || !$defs{$d}) {
|
|
$d = "<undefined>" if(!defined($d));
|
|
Log 0, "Strange call for nonexistent $d: $n";
|
|
return undef;
|
|
}
|
|
my $fn = $defs{$d}{$n} ? $defs{$d}{$n} : $defs{$d}{".$n"};
|
|
return CallFn($d, $n, @_) if(!$fn);
|
|
if(wantarray) {
|
|
no strict "refs";
|
|
my @ret = &{$fn}(@_);
|
|
use strict "refs";
|
|
return @ret;
|
|
} else {
|
|
no strict "refs";
|
|
my $ret = &{$fn}(@_);
|
|
use strict "refs";
|
|
return $ret;
|
|
}
|
|
}
|
|
|
|
#####################################
|
|
# Used from perl oneliners inside of scripts
|
|
sub
|
|
fhem($@)
|
|
{
|
|
my ($param, $silent) = @_;
|
|
my $ret = AnalyzeCommandChain(undef, $param);
|
|
Log 3, "$param : $ret" if($ret && !$silent);
|
|
return $ret;
|
|
}
|
|
|
|
#####################################
|
|
# initialize the global device
|
|
sub
|
|
doGlobalDef($)
|
|
{
|
|
my ($arg) = @_;
|
|
|
|
$devcount = 1;
|
|
$defs{global}{NR} = $devcount++;
|
|
$defs{global}{TYPE} = "Global";
|
|
$defs{global}{STATE} = "no definition";
|
|
$defs{global}{DEF} = "no definition";
|
|
$defs{global}{NAME} = "global";
|
|
|
|
CommandAttr(undef, "global verbose 3");
|
|
CommandAttr(undef, "global configfile $arg");
|
|
CommandAttr(undef, "global logfile -");
|
|
|
|
$devcountPrioSave = 2;
|
|
$devcount = 30;
|
|
$devcountTemp = 10000000;
|
|
}
|
|
|
|
#####################################
|
|
# rename does not work over Filesystems: lets copy it
|
|
sub
|
|
myrename($$$)
|
|
{
|
|
my ($name, $from, $to) = @_;
|
|
|
|
my $ca = AttrVal($name, "archiveCompress", 0);
|
|
if($ca) {
|
|
eval { require Compress::Zlib; };
|
|
if($@) {
|
|
$ca = 0;
|
|
Log 1, $@;
|
|
}
|
|
}
|
|
$to .= ".gz" if($ca);
|
|
|
|
if(!open(F, $from)) {
|
|
Log(1, "Rename: Cannot open $from: $!");
|
|
return;
|
|
}
|
|
if(!open(T, ">$to")) {
|
|
Log(1, "Rename: Cannot open $to: $!");
|
|
return;
|
|
}
|
|
|
|
if($ca) {
|
|
my $d = Compress::Zlib::deflateInit(-WindowBits=>31);
|
|
my $buf;
|
|
while(sysread(F,$buf,32768) > 0) {
|
|
syswrite(T, $d->deflate($buf));
|
|
}
|
|
syswrite(T, $d->flush());
|
|
} else {
|
|
while(my $l = <F>) {
|
|
print T $l;
|
|
}
|
|
}
|
|
close(F);
|
|
close(T);
|
|
unlink($from);
|
|
}
|
|
|
|
#####################################
|
|
# Make a directory and its parent directories if needed.
|
|
sub
|
|
HandleArchiving($;$)
|
|
{
|
|
my ($log,$flogInitial) = @_;
|
|
my $ln = $log->{NAME};
|
|
return if(!$attr{$ln});
|
|
|
|
# If there is a command, call that
|
|
my $cmd = $attr{$ln}{archivecmd};
|
|
if($cmd) {
|
|
return if($flogInitial); # Forum #41245
|
|
$cmd =~ s/%/$log->{currentlogfile}/g;
|
|
Log 2, "Archive: calling $cmd";
|
|
system($cmd);
|
|
return;
|
|
}
|
|
|
|
my $nra = $attr{$ln}{nrarchive};
|
|
my $ard = $attr{$ln}{archivedir};
|
|
return if(!defined($nra));
|
|
|
|
# If nrarchive is set, then check the last files:
|
|
# Get a list of files:
|
|
|
|
my ($dir, $file);
|
|
if($log->{logfile} =~ m,^(.+)/([^/]+)$,) {
|
|
($dir, $file) = ($1, $2);
|
|
} else {
|
|
($dir, $file) = (".", $log->{logfile});
|
|
}
|
|
|
|
$file =~ s/%./.+/g;
|
|
my $clf = $log->{currentlogfile};
|
|
$clf = $2 if($clf =~ m,^(.+)/([^/]+)$,);
|
|
|
|
my @t = localtime(gettimeofday());
|
|
$dir = ResolveDateWildcards($dir, @t);
|
|
return if(!opendir(DH, $dir));
|
|
my @files = sort grep {$_ =~ m/^$file$/ && $_ ne $clf } readdir(DH);
|
|
@files = sort { (stat("$dir/$a"))[9] <=> (stat("$dir/$b"))[9] } @files
|
|
if(AttrVal("global", "archivesort", "alphanum") eq "timestamp");
|
|
closedir(DH);
|
|
|
|
my $max = int(@files)-$nra;
|
|
for(my $i = 0; $i < $max; $i++) {
|
|
if($ard) {
|
|
Log 2, "Moving $files[$i] to $ard";
|
|
myrename($ln, "$dir/$files[$i]", "$ard/$files[$i]");
|
|
} else {
|
|
Log 2, "Deleting $files[$i]";
|
|
unlink("$dir/$files[$i]");
|
|
}
|
|
}
|
|
}
|
|
|
|
#####################################
|
|
# Call a logical device (FS20) ParseMessage with data from a physical device
|
|
# (FHZ). Note: $hash may be dummy, used by FHEM2FHEM
|
|
sub
|
|
Dispatch($$;$$)
|
|
{
|
|
my ($hash, $dmsg, $addvals, $nounknown) = @_;
|
|
my $module = $modules{$hash->{TYPE}};
|
|
my $name = $hash->{NAME};
|
|
|
|
if(GetVerbose($name) == 5) {
|
|
Log3 $hash, 5, escapeLogLine("$name: dispatch $dmsg");
|
|
}
|
|
|
|
my ($isdup, $idx) = CheckDuplicate($name, $dmsg, $module->{FingerprintFn});
|
|
return rejectDuplicate($name,$idx,$addvals) if($isdup);
|
|
|
|
my @found;
|
|
my $parserMod="";
|
|
my $clientArray = $hash->{".clientArray"};
|
|
$clientArray = computeClientArray($hash, $module) if(!$clientArray);
|
|
|
|
foreach my $m (@{$clientArray}) {
|
|
# The message is not for this module
|
|
next if($dmsg !~ m/$modules{$m}{Match}/s);
|
|
|
|
if( my $ffn = $modules{$m}{FingerprintFn} ) {
|
|
($isdup, $idx) = CheckDuplicate($name, $dmsg, $ffn);
|
|
return rejectDuplicate($name,$idx,$addvals) if($isdup);
|
|
}
|
|
|
|
no strict "refs"; $readingsUpdateDelayTrigger = 1;
|
|
my @tfound = &{$modules{$m}{ParseFn}}($hash,$dmsg);
|
|
use strict "refs"; $readingsUpdateDelayTrigger = 0;
|
|
$parserMod = $m;
|
|
if(int(@tfound) && defined($tfound[0])) {
|
|
if($tfound[0] && $tfound[0] eq "[NEXT]") { # not a goodDeviceName, #95446
|
|
shift(@tfound);
|
|
push @found, @tfound; # continue feeding other modules
|
|
} else {
|
|
push @found, @tfound;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
if((!int(@found) || !defined($found[0])) && !$nounknown) {
|
|
my $h = $hash->{MatchList};
|
|
$h = $module->{MatchList} if(!$h);
|
|
if(defined($h)) {
|
|
foreach my $m (sort keys %{$h}) {
|
|
my ($order, $mname) = split(":", $m);
|
|
next if(!$modules{$mname} || # #130952 / FS20V
|
|
$modules{$mname}{LOADED}); # checked in the loop above, #125292
|
|
if($dmsg =~ m/$h->{$m}/s) {
|
|
if(AttrVal("global", "autoload_undefined_devices", 1)) {
|
|
my $newm = LoadModule($mname);
|
|
$mname = $newm if($newm ne "UNDEFINED");
|
|
if($modules{$mname} && $modules{$mname}{ParseFn}) {
|
|
no strict "refs"; $readingsUpdateDelayTrigger = 1;
|
|
my @tfound = &{$modules{$mname}{ParseFn}}($hash,$dmsg);
|
|
use strict "refs"; $readingsUpdateDelayTrigger = 0;
|
|
$parserMod = $mname;
|
|
delete($hash->{".clientArray"});
|
|
|
|
if(int(@tfound) && defined($tfound[0])) {
|
|
if($tfound[0] && $tfound[0] eq "[NEXT]") {
|
|
shift(@tfound);
|
|
push @found, @tfound;
|
|
} else {
|
|
push @found, @tfound;
|
|
last;
|
|
}
|
|
}
|
|
|
|
} else {
|
|
Log 0, "ERROR: Cannot autoload $mname";
|
|
}
|
|
|
|
} else {
|
|
Log3 $name, 3, "$name: Unknown $mname device detected, " .
|
|
"define one to get detailed information.";
|
|
return undef;
|
|
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if((!int(@found) || !defined($found[0])) && !$nounknown) {
|
|
DoTrigger($name, "UNKNOWNCODE $dmsg");
|
|
Log3 $name, 3, "$name: Unknown code $dmsg, help me!";
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
################
|
|
# Inform raw
|
|
if(!$module->{noRawInform}) {
|
|
foreach my $c (keys %inform) {
|
|
if(!$defs{$c} || $defs{$c}{NR} != $inform{$c}{NR}) {
|
|
delete($inform{$c});
|
|
next;
|
|
}
|
|
next if($inform{$c}{type} ne "raw");
|
|
syswrite($defs{$c}{CD}, "$hash->{TYPE} $name $dmsg\n");
|
|
}
|
|
}
|
|
|
|
# Special return: Do not notify
|
|
return undef if(!defined($found[0]) || $found[0] eq "");
|
|
|
|
foreach my $found (@found) {
|
|
|
|
if($found =~ m/^(UNDEFINED.*)/) {
|
|
DoTrigger("global", $1);
|
|
return undef;
|
|
|
|
} else {
|
|
if($defs{$found}) {
|
|
if(!$defs{$found}{".noDispatchVars"}) { # CUL_HM special
|
|
$defs{$found}{MSGCNT}++;
|
|
my $avtrigger = ($attr{$name} && $attr{$name}{addvaltrigger});
|
|
if($addvals) {
|
|
foreach my $av (keys %{$addvals}) {
|
|
$defs{$found}{"${name}_$av"} = $addvals->{$av};
|
|
push(@{$defs{$found}{CHANGED}}, "$av: $addvals->{$av}")
|
|
if($avtrigger);
|
|
}
|
|
}
|
|
$defs{$found}{"${name}_MSGCNT"}++;
|
|
$defs{$found}{"${name}_TIME"} = TimeNow();
|
|
$defs{$found}{LASTInputDev} = $name;
|
|
}
|
|
delete($defs{$found}{".noDispatchVars"});
|
|
DoTrigger($found, undef);
|
|
|
|
} elsif(defined($found) && ($found eq "" || $found eq "[NEXT]")) {
|
|
return undef;
|
|
|
|
} else {
|
|
Log 1, "ERROR: >$found< returned by the $parserMod ParseFn is invalid,".
|
|
" notify the module maintainer";
|
|
return undef;
|
|
}
|
|
}
|
|
}
|
|
|
|
$duplicate{$idx}{FND} = \@found
|
|
if(defined($idx) && defined($duplicate{$idx}));
|
|
|
|
return \@found;
|
|
}
|
|
|
|
sub
|
|
CheckDuplicate($$@)
|
|
{
|
|
my ($ioname, $msg, $ffn) = @_;
|
|
|
|
if($ffn) {
|
|
no strict "refs";
|
|
($ioname,$msg) = &{$ffn}($ioname,$msg);
|
|
use strict "refs";
|
|
return (0, undef) if( !defined($msg) );
|
|
#Debug "got $ffn ". $ioname .":". $msg;
|
|
}
|
|
|
|
my $now = gettimeofday();
|
|
my $lim = $now-AttrVal("global","dupTimeout", 0.5);
|
|
|
|
foreach my $oidx (keys %duplicate) {
|
|
if($duplicate{$oidx}{TIM} < $lim) {
|
|
delete($duplicate{$oidx});
|
|
|
|
} elsif($duplicate{$oidx}{MSG} eq $msg &&
|
|
$duplicate{$oidx}{ION} eq "") {
|
|
return (1, $oidx);
|
|
|
|
} elsif($duplicate{$oidx}{MSG} eq $msg &&
|
|
$duplicate{$oidx}{ION} ne $ioname) {
|
|
return (1, $oidx);
|
|
|
|
}
|
|
}
|
|
#Debug "is unique";
|
|
$duplicate{$duplidx}{ION} = $ioname;
|
|
$duplicate{$duplidx}{MSG} = $msg;
|
|
$duplicate{$duplidx}{TIM} = $now;
|
|
$duplidx++;
|
|
return (0, $duplidx-1);
|
|
}
|
|
|
|
sub
|
|
rejectDuplicate($$$)
|
|
{
|
|
#Debug "is duplicate";
|
|
my ($name,$idx,$addvals) = @_;
|
|
my $found = $duplicate{$idx}{FND};
|
|
foreach my $found (@{$found}) {
|
|
if($addvals) {
|
|
foreach my $av (keys %{$addvals}) {
|
|
$defs{$found}{"${name}_$av"} = $addvals->{$av};
|
|
}
|
|
}
|
|
$defs{$found}{"${name}_MSGCNT"}++;
|
|
$defs{$found}{"${name}_TIME"} = TimeNow();
|
|
}
|
|
return $duplicate{$idx}{FND};
|
|
}
|
|
|
|
sub
|
|
AddDuplicate($$)
|
|
{
|
|
$duplicate{$duplidx}{ION} = shift;
|
|
$duplicate{$duplidx}{MSG} = shift;
|
|
$duplicate{$duplidx}{TIM} = gettimeofday();
|
|
$duplidx++;
|
|
}
|
|
|
|
# Add an attribute to the userattr list, if not yet present
|
|
# module is the source, needed when searching for help
|
|
sub
|
|
addToDevAttrList($$;$)
|
|
{
|
|
my ($dev,$arg,$module) = @_;
|
|
|
|
my $ua = $attr{$dev}{userattr};
|
|
$ua = "" if(!$ua);
|
|
my %hash = map { ($_ => 1) }
|
|
grep { " $AttrList " !~ m/ $_ / }
|
|
split(" ", "$ua $arg");
|
|
$attr{$dev}{userattr} = join(" ", sort keys %hash);
|
|
map { s/:.*//; $attrSource{$_} = $module; } split(" ", $arg) if($module);
|
|
}
|
|
|
|
# The counterpart: delete it.
|
|
sub
|
|
delFromDevAttrList($$)
|
|
{
|
|
my ($dev,$arg) = @_;
|
|
|
|
my $ua = $attr{$dev}{userattr};
|
|
$ua = "" if(!$ua);
|
|
my %hash = map { ($_ => 1) }
|
|
grep { $_ !~ m/^$arg(:.+)?$/ }
|
|
split(" ", $ua);
|
|
$attr{$dev}{userattr} = join(" ", sort keys %hash);
|
|
delete $attr{$dev}{userattr}
|
|
if(!keys %hash && defined($attr{$dev}{userattr}));
|
|
map { delete $attr{$dev}{$_} } split(" ", (split(":", $arg))[0]);
|
|
}
|
|
|
|
|
|
sub
|
|
addToAttrList($;$)
|
|
{
|
|
my ($arg,$module) = @_;
|
|
addToDevAttrList("global", $arg, $module);
|
|
}
|
|
|
|
sub
|
|
delFromAttrList($)
|
|
{
|
|
delFromDevAttrList("global", shift);
|
|
}
|
|
|
|
# device specific attrList, overwrites module AttrList, user undef for $argList
|
|
# to delete it
|
|
sub
|
|
setDevAttrList($;$)
|
|
{
|
|
my ($dev,$argList) = @_;
|
|
return if(!$defs{$dev});
|
|
if(defined($argList)) {
|
|
$defs{$dev}{".AttrList"} = $argList;
|
|
} else {
|
|
delete($defs{$dev}{".AttrList"});
|
|
}
|
|
}
|
|
|
|
sub
|
|
attrSplit($)
|
|
{
|
|
my ($em) = @_;
|
|
my $sc = " "; # Split character
|
|
my $fc = substr($em, 0, 1); # First character of the eventMap
|
|
if($fc eq "," || $fc eq "/") {
|
|
$sc = $fc;
|
|
$em = substr($em, 1);
|
|
}
|
|
return split($sc, $em);
|
|
}
|
|
|
|
#######################
|
|
# $dir: 0: User to Device (i.e. set), $str is an array pointer
|
|
# $dir: 1: Device to Usr (i.e trigger), $str is a a string
|
|
sub
|
|
ReplaceEventMap($$$)
|
|
{
|
|
my ($dev, $str, $dir) = @_;
|
|
my $em = AttrVal($dev, "eventMap", undef);
|
|
|
|
return $str if($dir && !$em);
|
|
return @{$str} if(!$dir && (!$em || int(@{$str}) < 2 ||
|
|
!defined($str->[1]) || $str->[1] eq "?"));
|
|
|
|
return ReplaceEventMap2($dev, $str, $dir, $em) if($em =~ m/^{.*}$/s);
|
|
my @emList = attrSplit($em);
|
|
|
|
if(!defined $defs{$dev}{".eventMapCmd"}) {
|
|
# Delete the first word of the translation (.*:), else it will be
|
|
# interpreted as the single possible value for a dropdown
|
|
# Why is the .*= deleted?
|
|
$defs{$dev}{".eventMapCmd"} = join(" ", grep { !/ / }
|
|
map { $_ =~ s/.*?=//s; $_ =~ s/.*?://s;
|
|
$_ =~ m/:/ ? $_ : "$_:noArg" } @emList);
|
|
}
|
|
|
|
my ($dname, $nstr);
|
|
$dname = shift @{$str} if(!$dir);
|
|
$nstr = join(" ", @{$str}) if(!$dir);
|
|
|
|
my $changed;
|
|
foreach my $rv (@emList) {
|
|
# Real-Event-Regexp:GivenName[:modifier]
|
|
my ($re, $val, $modifier) = split(":", $rv, 3);
|
|
next if(!defined($val));
|
|
if($dir) { # dev -> usr
|
|
my $reIsWord = ($re =~ m/^\w*$/); # dim100% is not \w only, cant use \b
|
|
if($reIsWord) {
|
|
if($str =~ m/\b$re\b/) {
|
|
$str =~ s/\b$re\b/$val/;
|
|
$changed = 1;
|
|
}
|
|
} else {
|
|
if($str =~ m/$re/) {
|
|
$str =~ s/$re/$val/;
|
|
$changed = 1;
|
|
}
|
|
}
|
|
|
|
} else { # usr -> dev
|
|
if($nstr eq $val) { # for special translations like <> and <<
|
|
$nstr = $re;
|
|
$changed = 1;
|
|
} else {
|
|
my $reIsWord = ($val =~ m/^\w*$/);
|
|
if($reIsWord) {
|
|
if($nstr =~ m/\b$val\b/) {
|
|
$nstr =~ s/\b$val\b/$re/;
|
|
$changed = 1;
|
|
}
|
|
} elsif($nstr =~ m/$val/) {
|
|
$nstr =~ s/$val/$re/;
|
|
$changed = 1;
|
|
}
|
|
}
|
|
}
|
|
last if($changed);
|
|
|
|
}
|
|
return $str if($dir);
|
|
|
|
if($changed) {
|
|
my @arr = split(" ",$nstr);
|
|
unshift @arr, $dname;
|
|
return @arr;
|
|
} else {
|
|
unshift @{$str}, $dname;
|
|
return @{$str};
|
|
}
|
|
}
|
|
|
|
# $dir: 0:usr,$str is array pointer, 1:dev, $str is string
|
|
# perl notation: { dev=>{"re1"=>"Evt1",...}, fw=>{"re1"=>"Set 1",...}}
|
|
sub
|
|
ReplaceEventMap2($$$)
|
|
{
|
|
my ($dev, $str, $dir) = @_;
|
|
|
|
my $hash = $defs{$dev};
|
|
my $emh = $hash->{".eventMapHash"};
|
|
if(!$emh) {
|
|
eval "\$emh = $attr{$dev}{eventMap}";
|
|
if($@) {
|
|
my $msg = "ERROR in eventMap for $dev: $@";
|
|
Log 1, $msg;
|
|
return $msg;
|
|
}
|
|
$hash->{".eventMapHash"} = $emh;
|
|
|
|
$defs{$dev}{".eventMapCmd"} = "";
|
|
if($emh->{usr}) {
|
|
my @cmd;
|
|
my $fw = $emh->{fw};
|
|
$defs{$dev}{".eventMapCmd"} = join(" ",
|
|
map { ($fw && $fw->{$_}) ? $fw->{$_}:$_} sort keys %{$emh->{usr} });
|
|
}
|
|
}
|
|
|
|
if($dir == 1) {
|
|
$emh = $emh->{dev};
|
|
if($emh) {
|
|
foreach my $k (keys %{$emh}) {
|
|
return $emh->{$k} if($str eq $k);
|
|
return eval '"'.$emh->{$k}.'"' if($str =~ m/$k/);
|
|
}
|
|
}
|
|
return $str;
|
|
}
|
|
|
|
$emh = $emh->{usr};
|
|
return @{$str} if(!$emh);
|
|
|
|
my $dname = shift @{$str};
|
|
my $nstr = join(" ", @{$str});
|
|
foreach my $k (keys %{$emh}) {
|
|
my $nv;
|
|
if($nstr eq $k) {
|
|
$nv = $emh->{$k};
|
|
|
|
} elsif($nstr =~ m/$k/) {
|
|
my $NAME = $dev; # Compatibility, Forum #43023
|
|
$nv = eval '"'.$emh->{$k}.'"';
|
|
|
|
}
|
|
if(defined($nv)) {
|
|
my @arr = split(" ",$nv);
|
|
unshift @arr, $dname;
|
|
return @arr;
|
|
}
|
|
}
|
|
unshift @{$str}, $dname;
|
|
return @{$str};
|
|
}
|
|
|
|
# Needed for logfile/pid/nofork
|
|
sub
|
|
setGlobalAttrBeforeFork($)
|
|
{
|
|
my ($f) = @_;
|
|
|
|
my ($err, @rows);
|
|
if($f eq 'configDB') {
|
|
@rows = cfgDB_AttrRead('global');
|
|
} else {
|
|
($err, @rows) = FileRead($f);
|
|
die("$err\n") if($err);
|
|
}
|
|
|
|
foreach my $l (@rows) {
|
|
$l =~ s/[\r\n]//g;
|
|
next if($l !~ m/^attr\s+global\s+([^\s]+)\s+(.*)$/);
|
|
AnalyzeCommand(undef, $l);
|
|
}
|
|
CommandAttr(undef, "global modpath .") if(!AttrVal("global","modpath",""));
|
|
}
|
|
|
|
sub
|
|
resolveAttrRename($$)
|
|
{
|
|
my ($d,$n) = @_;
|
|
|
|
return $n if(!$d || !$defs{$d});
|
|
my $m = $modules{$defs{$d}{TYPE}};
|
|
if($m->{AttrRenameMap} && defined($m->{AttrRenameMap}{$n})) {
|
|
Log 3, "WARNING: $d attribute $n was renamed to ".$m->{AttrRenameMap}{$n};
|
|
return $m->{AttrRenameMap}{$n};
|
|
}
|
|
|
|
return $n;
|
|
}
|
|
|
|
|
|
###########################################
|
|
# Functions used to make fhem-oneliners more readable,
|
|
# but also recommended to be used by modules
|
|
sub
|
|
numberFromString($$;$)
|
|
{
|
|
my ($val,$default,$round) = @_;
|
|
return undef if(!defined($val));
|
|
# 137283 & perl cookbook
|
|
$val = ($val =~ /(([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)/ ? $1 : "");
|
|
$val =~ s/^([+-]?)0+([1-9])/$1$2/; # Forum #135120, dont want octal numbers
|
|
return $default if($val eq "");
|
|
$val = round($val,$round) if(defined $round);
|
|
return $val;
|
|
}
|
|
|
|
sub
|
|
InternalVal($$$)
|
|
{
|
|
my ($d,$n,$default) = @_;
|
|
if(defined($defs{$d}) &&
|
|
defined($defs{$d}{$n})) {
|
|
return $defs{$d}{$n};
|
|
}
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
InternalNum($$$;$)
|
|
{
|
|
my ($d,$n,$default,$round) = @_;
|
|
return numberFromString(InternalVal($d,$n,$default),$default,$round);
|
|
}
|
|
|
|
sub
|
|
OldReadingsVal($$$)
|
|
{
|
|
my ($d,$n,$default) = @_;
|
|
if(defined($defs{$d}) &&
|
|
defined($defs{$d}{OLDREADINGS}) &&
|
|
defined($defs{$d}{OLDREADINGS}{$n}) &&
|
|
defined($defs{$d}{OLDREADINGS}{$n}{VAL})) {
|
|
return $defs{$d}{OLDREADINGS}{$n}{VAL};
|
|
}
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
OldReadingsNum($$$;$)
|
|
{
|
|
my ($d,$n,$default,$round) = @_;
|
|
return numberFromString(OldReadingsVal($d,$n,$default),$default,$round);
|
|
}
|
|
|
|
sub
|
|
OldReadingsTimestamp($$$)
|
|
{
|
|
my ($d,$n,$default) = @_;
|
|
if(defined($defs{$d}) &&
|
|
defined($defs{$d}{OLDREADINGS}) &&
|
|
defined($defs{$d}{OLDREADINGS}{$n}) &&
|
|
defined($defs{$d}{OLDREADINGS}{$n}{TIME})) {
|
|
return $defs{$d}{OLDREADINGS}{$n}{TIME};
|
|
}
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
OldReadingsAge($$$)
|
|
{
|
|
my ($device,$reading,$default) = @_;
|
|
my $ts = OldReadingsTimestamp($device,$reading,undef);
|
|
return int(gettimeofday() - time_str2num($ts)) if(defined($ts));
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
ReadingsVal($$$)
|
|
{
|
|
my ($d,$n,$default) = @_;
|
|
if(defined($defs{$d}) &&
|
|
defined($defs{$d}{READINGS}) &&
|
|
defined($defs{$d}{READINGS}{$n}) &&
|
|
defined($defs{$d}{READINGS}{$n}{VAL})) {
|
|
return $defs{$d}{READINGS}{$n}{VAL};
|
|
}
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
ReadingsNum($$$;$)
|
|
{
|
|
my ($d,$n,$default,$round) = @_;
|
|
return numberFromString(ReadingsVal($d,$n,$default),$default,$round);
|
|
}
|
|
|
|
sub
|
|
ReadingsTimestamp($$$)
|
|
{
|
|
my ($d,$n,$default) = @_;
|
|
if(defined($defs{$d}) &&
|
|
defined($defs{$d}{READINGS}) &&
|
|
defined($defs{$d}{READINGS}{$n}) &&
|
|
defined($defs{$d}{READINGS}{$n}{TIME})) {
|
|
return $defs{$d}{READINGS}{$n}{TIME};
|
|
}
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
ReadingsAge($$$)
|
|
{
|
|
my ($device,$reading,$default) = @_;
|
|
my $ts = ReadingsTimestamp($device,$reading,undef);
|
|
return int(gettimeofday() - time_str2num($ts)) if(defined($ts));
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
Value($)
|
|
{
|
|
my ($d) = @_;
|
|
if(defined($defs{$d}) &&
|
|
defined($defs{$d}{STATE})) {
|
|
return $defs{$d}{STATE};
|
|
}
|
|
return "";
|
|
}
|
|
|
|
sub
|
|
OldValue($)
|
|
{
|
|
my ($d) = @_;
|
|
return $oldvalue{$d}{VAL} if(defined($oldvalue{$d})) ;
|
|
return "";
|
|
}
|
|
|
|
sub
|
|
OldTimestamp($)
|
|
{
|
|
my ($d) = @_;
|
|
return $oldvalue{$d}{TIME} if(defined($oldvalue{$d})) ;
|
|
return "";
|
|
}
|
|
|
|
sub
|
|
AttrVal($$$)
|
|
{
|
|
my ($d,$n,$default) = @_;
|
|
$n = resolveAttrRename($d, $n);
|
|
return $attr{$d}{$n} if(defined($attr{$d}) && defined($attr{$d}{$n}));
|
|
return $default;
|
|
}
|
|
|
|
sub
|
|
AttrNum($$$;$)
|
|
{
|
|
my ($d,$n,$default,$round) = @_;
|
|
my $val = AttrVal($d,$n,$default);
|
|
return undef if(!defined($val));
|
|
$val = ($val =~ /(-?\d+(\.\d+)?)/ ? $1 : "");
|
|
$val = round($val,$round) if($round);
|
|
return $val;
|
|
}
|
|
|
|
sub
|
|
fhem_devSupportsAttr($$)
|
|
{
|
|
my ($devName,$attrName) = @_;
|
|
my $attrList = getAllAttr($devName);
|
|
return (" $attrList " =~ m/ $attrName[ :;]/);
|
|
}
|
|
|
|
################################################################
|
|
# Functions used by modules.
|
|
sub
|
|
setReadingsVal($$$$)
|
|
{
|
|
my ($hash,$rname,$val,$ts) = @_;
|
|
|
|
return if($rname eq "IODev" && !fhem_devSupportsAttr($hash->{NAME}, "IODev"));
|
|
|
|
my $or = $hash->{".or"};
|
|
if($or && grep($rname =~ m/^$_$/, @{$or}) ) {
|
|
my $rd = $hash->{READINGS};
|
|
if(defined($rd->{$rname}) &&
|
|
defined($rd->{$rname}{VAL}) &&
|
|
($or->[@{$or}-1] eq "oldreadingsAlways" ||
|
|
$rd->{$rname}{VAL} ne $val) ) {
|
|
$hash->{OLDREADINGS}{$rname}{VAL} = $rd->{$rname}{VAL};
|
|
$hash->{OLDREADINGS}{$rname}{TIME} = $rd->{$rname}{TIME};
|
|
}
|
|
}
|
|
|
|
$hash->{READINGS}{$rname}{VAL} = $val;
|
|
$hash->{READINGS}{$rname}{TIME} = $ts;
|
|
}
|
|
|
|
sub
|
|
addEvent($$;$)
|
|
{
|
|
my ($hash,$event,$timestamp) = @_;
|
|
push(@{$hash->{CHANGED}}, $event);
|
|
if($timestamp) {
|
|
$hash->{CHANGETIME} = [] if(!defined($hash->{CHANGETIME}));
|
|
$hash->{CHANGETIME}->[@{$hash->{CHANGED}}-1] = $timestamp;
|
|
}
|
|
}
|
|
|
|
sub
|
|
concatc($$$) {
|
|
my ($separator,$a,$b)= @_;;
|
|
return($a && $b ? $a . $separator . $b : $a . $b);
|
|
}
|
|
|
|
################################################################
|
|
#
|
|
# Wrappers for commonly used core functions in device-specific modules.
|
|
#
|
|
################################################################
|
|
|
|
#
|
|
# Call readingsBeginUpdate before you start updating readings.
|
|
# The updated readings will all get the same timestamp,
|
|
# which is the time when you called this subroutine.
|
|
#
|
|
sub
|
|
readingsBeginUpdate($)
|
|
{
|
|
my ($hash)= @_;
|
|
my $name = $hash->{NAME};
|
|
|
|
if(!$name) {
|
|
Log 1, "ERROR: empty name in readingsBeginUpdate";
|
|
stacktrace();
|
|
return;
|
|
}
|
|
|
|
# get timestamp
|
|
my $now = gettimeofday();
|
|
my $fmtDateTime = FmtDateTime($now);
|
|
$hash->{".updateTime"} = $now; # in seconds since the epoch
|
|
$hash->{".updateTimestamp"} = $fmtDateTime;
|
|
|
|
$hash->{CHANGED}= [] if(!defined($hash->{CHANGED}));
|
|
return $fmtDateTime;
|
|
}
|
|
|
|
sub
|
|
evalStateFormat($)
|
|
{
|
|
my ($hash) = @_;
|
|
|
|
my $name = $hash->{NAME};
|
|
|
|
###########################
|
|
# Set STATE
|
|
my $st = $hash->{READINGS}{state};
|
|
if($hash->{skipStateFormat} && defined($st)) {
|
|
$hash->{STATE} = ReplaceEventMap($name, $st->{VAL}, 1);
|
|
return;
|
|
}
|
|
|
|
my $sr = AttrVal($name, "stateFormat", undef);
|
|
if(!$sr) {
|
|
$st = $st->{VAL} if(defined($st));
|
|
|
|
} elsif($sr =~ m/^{(.*)}$/s) {
|
|
$cmdFromAnalyze = $1;
|
|
$st = eval $1;
|
|
if($@) {
|
|
$st = "Error evaluating $name stateFormat: $@";
|
|
Log 1, $st;
|
|
}
|
|
$cmdFromAnalyze = undef;
|
|
|
|
} else {
|
|
# Substitute reading names with their values, leave the rest untouched.
|
|
$st = $sr;
|
|
my $r = $hash->{READINGS};
|
|
$st =~ s/\$name/$name/g;
|
|
(undef, $st) = ReplaceSetMagic($hash, 1, $st);
|
|
$st =~ s/\b([A-Za-z\d_\.-]+)\b/($r->{$1} ? $r->{$1}{VAL} : $1)/ge
|
|
if($st eq $sr);
|
|
|
|
}
|
|
$hash->{STATE} = ReplaceEventMap($name, $st, 1) if(defined($st));
|
|
}
|
|
|
|
#
|
|
# Call readingsEndUpdate when you are done updating readings.
|
|
# This optionally calls DoTrigger to propagate the changes.
|
|
#
|
|
sub
|
|
readingsEndUpdate($$)
|
|
{
|
|
my ($hash,$dotrigger)= @_;
|
|
my $name = $hash->{NAME};
|
|
|
|
$hash->{".triggerUsed"} = 1 if(defined($hash->{".triggerUsed"}));
|
|
|
|
# process user readings
|
|
if(defined($hash->{'.userReadings'})) {
|
|
foreach my $userReading (@{$hash->{'.userReadings'}}) {
|
|
|
|
my $trigger = $userReading->{trigger};
|
|
my $reading= $userReading->{reading};
|
|
my ($event, $eventName, $eventValue, $ownRead);
|
|
if(defined($trigger)) {
|
|
map { $event = $_ if(defined($_) && $_ =~ m/^$trigger$/);
|
|
$ownRead = 1 if(defined($_) && $_ =~ m/^$reading:/); }
|
|
@{$hash->{CHANGED}};
|
|
next if(!defined($event) || $ownRead);
|
|
($eventName, $eventValue) = ($1, $2) if($event =~ m/^([^:]*): (.*)$/);
|
|
}
|
|
|
|
my $modifier= $userReading->{modifier};
|
|
my $perlCode= $userReading->{perlCode};
|
|
my $oldvalue= $userReading->{value};
|
|
my $oldt= $userReading->{t};
|
|
#Debug "Evaluating " . $reading;
|
|
$cmdFromAnalyze = $perlCode; # For the __WARN__ sub
|
|
my $NAME = $name; # no exceptions, #53069
|
|
|
|
my $stopRecursion = ".evalUserReading_$reading";
|
|
next if($hash->{$stopRecursion}); # No warning / #138149
|
|
$hash->{$stopRecursion} = 1;
|
|
my $value= eval $perlCode;
|
|
delete($hash->{$stopRecursion});
|
|
$cmdFromAnalyze = undef;
|
|
|
|
my $result;
|
|
# store result
|
|
if($@) {
|
|
$value = "Error evaluating $name userReading $reading: $@";
|
|
Log 1, $value;
|
|
$result= $value;
|
|
} elsif(!defined($value)) {
|
|
if(AttrVal("global", "verbose", 3) >= 5) { #102868
|
|
$cmdFromAnalyze = $perlCode; # For the __WARN__ sub
|
|
warn("$name userReadings $reading evaluated to undef");
|
|
}
|
|
next;
|
|
} elsif($modifier eq "none") {
|
|
$result= $value;
|
|
} elsif($modifier eq "difference") {
|
|
$result= $value - $oldvalue if(defined($oldvalue));
|
|
} elsif($modifier eq "differential") {
|
|
my ($deltav, $deltat);
|
|
$deltav = $value - $oldvalue if(defined($oldvalue));
|
|
$deltat = $hash->{".updateTime"} - $oldt if(defined($oldt));
|
|
if(defined($deltav) && defined($deltat) && ($deltat>= 1.0)) {
|
|
$result= $deltav/$deltat;
|
|
}
|
|
} elsif($modifier eq "integral") {
|
|
if(defined($oldt) && defined($oldvalue)) {
|
|
my $deltat;
|
|
$deltat = $hash->{".updateTime"} - $oldt if(defined($oldt));
|
|
my $avgval= ($value + $oldvalue) / 2;
|
|
$result = ReadingsVal($name,$reading,$value);
|
|
if(defined($deltat) && $deltat>= 1.0) {
|
|
$result+= $avgval*$deltat;
|
|
}
|
|
}
|
|
} elsif($modifier eq "offset") {
|
|
$oldvalue = $value if( !defined($oldvalue) );
|
|
$result = ReadingsVal($name,$reading,0);
|
|
$result += $oldvalue if( $value < $oldvalue );
|
|
} elsif($modifier eq "monotonic") {
|
|
$oldvalue = $value if( !defined($oldvalue) );
|
|
$result = ReadingsVal($name,$reading,$value);
|
|
$result += $value - $oldvalue if( $value > $oldvalue );
|
|
}
|
|
readingsBulkUpdate($hash,$reading,$result,1) if(defined($result));
|
|
# store value
|
|
$userReading->{TIME}= $hash->{".updateTimestamp"};
|
|
$userReading->{t}= $hash->{".updateTime"};
|
|
$userReading->{value}= $value;
|
|
}
|
|
}
|
|
evalStateFormat($hash);
|
|
|
|
# turn off updating mode
|
|
delete $hash->{".updateTimestamp"};
|
|
delete $hash->{".updateTime"};
|
|
|
|
|
|
# propagate changes
|
|
if($dotrigger && $init_done) {
|
|
DoTrigger($name, undef, 0) if(!$readingsUpdateDelayTrigger);
|
|
} else {
|
|
if(!defined($hash->{INTRIGGER})) {
|
|
delete($hash->{CHANGED});
|
|
delete($hash->{CHANGEDWITHSTATE})
|
|
}
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
sub
|
|
readingsBulkUpdateIfChanged($$$@) # Forum #58797
|
|
{
|
|
my ($hash,$reading,$value,$changed)= @_;
|
|
return undef if($value eq ReadingsVal($hash->{NAME},$reading,""));
|
|
return readingsBulkUpdate($hash,$reading,$value,$changed);
|
|
}
|
|
|
|
# Call readingsBulkUpdate to update the reading.
|
|
# Example: readingsUpdate($hash,"temperature",$value);
|
|
# Optional parameter $changed: if defined, and is 0, do not trigger events. If
|
|
# 1, trigger. If not defined, the name of the reading decides (starting with .
|
|
# is 0, else 1). The event-on-* filtering is done additionally.
|
|
#
|
|
sub
|
|
readingsBulkUpdate($$$@)
|
|
{
|
|
my ($hash,$reading,$value,$changed,$timestamp)= @_;
|
|
my $name= $hash->{NAME};
|
|
|
|
return if(!defined($reading) || !defined($value));
|
|
# sanity check
|
|
if(!defined($hash->{".updateTimestamp"})) {
|
|
Log 1, "readingsUpdate($name,$reading,$value) missed to call ".
|
|
"readingsBeginUpdate first.";
|
|
stacktrace();
|
|
return;
|
|
}
|
|
|
|
my $sp = AttrVal($name, "suppressReading", undef);
|
|
return if($sp && $reading =~ m/^$sp$/);
|
|
|
|
# shorthand
|
|
my $readings = $hash->{READINGS}{$reading};
|
|
|
|
if(!defined($changed)) {
|
|
$changed = (substr($reading,0,1) ne "."); # Dont trigger dot-readings
|
|
}
|
|
$changed = 0 if($hash->{".ignoreEvent"});
|
|
|
|
# if reading does not exist yet: fake entry to allow filtering
|
|
$readings = { VAL => "" } if( !defined($readings) );
|
|
|
|
my $update_timestamp = 1;
|
|
if($changed) {
|
|
|
|
# these flags determine if any of the "event-on" attributes are set
|
|
my $attreocr = $hash->{".attreocr"};
|
|
my $attreour = $hash->{".attreour"};
|
|
|
|
# determine whether the reading is listed in any of the attributes
|
|
my $eocr = $attreocr &&
|
|
( my @eocrv = grep { my $l = $_; $l =~ s/:.*//;
|
|
($reading=~ m/^$l$/) ? $_ : undef} @{$attreocr});
|
|
my $eour = $attreour && grep($reading =~ m/^$_$/, @{$attreour});
|
|
|
|
# check if threshold is given
|
|
my $eocrExists = $eocr;
|
|
if( $eocr
|
|
&& $eocrv[0] =~ m/.*:(.*)/ ) {
|
|
my $threshold = $1;
|
|
|
|
if($value =~ m/([\d\.\-eE]+)/ && looks_like_number($1)) { #41083, #62190
|
|
my $mv = $1;
|
|
my $last_value = $hash->{".attreocr-threshold$reading"};
|
|
if( !defined($last_value) ) {
|
|
$hash->{".attreocr-threshold$reading"} = $mv;
|
|
} elsif( abs($mv - $last_value) < $threshold ) {
|
|
$eocr = 0;
|
|
} else {
|
|
$hash->{".attreocr-threshold$reading"} = $mv;
|
|
}
|
|
}
|
|
}
|
|
|
|
# determine if an event should be created:
|
|
# always create event if no attribute is set
|
|
# or if the reading is listed in event-on-update-reading
|
|
# or if the reading is listed in event-on-change-reading...
|
|
# ...and its value has changed...
|
|
# ...and the change greater then the threshold
|
|
$changed= !($attreocr || $attreour)
|
|
|| $eour
|
|
|| ($eocr && ($value ne $readings->{VAL}));
|
|
#Log 1, "EOCR:$eocr EOUR:$eour CHANGED:$changed";
|
|
|
|
my @v = grep { my $l = $_;
|
|
$l =~ s/:.*//;
|
|
($reading=~ m/^$l$/) ? $_ : undef} @{$hash->{".attrminint"}};
|
|
if(@v) {
|
|
my (undef, $minInt) = split(":", $v[0]);
|
|
my $now = $hash->{".updateTime"};
|
|
my $le = $hash->{".lastTime$reading"};
|
|
if($le && $now-$le < $minInt) {
|
|
if(!$eocr || ($eocr && $value eq $readings->{VAL})){
|
|
$changed = 0;
|
|
} else {
|
|
$hash->{".lastTime$reading"} = $now;
|
|
}
|
|
} else {
|
|
$hash->{".lastTime$reading"} = $now;
|
|
$changed = 1 if($eocrExists);
|
|
}
|
|
}
|
|
|
|
if( $attreocr ) {
|
|
if( my $attrtocr = $hash->{".attrtocr"} ) {
|
|
$update_timestamp = $changed
|
|
if( $attrtocr && grep($reading =~ m/^$_$/, @{$attrtocr}) );
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
if($changed) {
|
|
#Debug "Processing $reading: $value";
|
|
my @v = grep { my $l = $_;
|
|
$l =~ s/:.*//;
|
|
($reading=~ m/^$l$/) ? $_ : undef} @{$hash->{".attraggr"}};
|
|
if(@v) {
|
|
# e.g. power:20:linear:avg
|
|
my (undef,$duration,$method,$function,$holdTime) = split(":", $v[0], 5);
|
|
my $ts;
|
|
if(defined($readings->{".ts"})) {
|
|
$ts= $readings->{".ts"};
|
|
} else {
|
|
require "TimeSeries.pm";
|
|
$ts = TimeSeries->new( { method => $method,
|
|
autoreset => $duration,
|
|
holdTime => $holdTime } );
|
|
$readings->{".ts"}= $ts;
|
|
# access from command line:
|
|
# { $defs{"myClient"}{READINGS}{"myValue"}{".ts"}{max} }
|
|
#Debug "TimeSeries created.";
|
|
}
|
|
my $now = $hash->{".updateTime"};
|
|
my $val = $value; # save value
|
|
$changed = $ts->elapsed($now);
|
|
$value = $ts->{$function} if($changed);
|
|
$ts->add($now, $val);
|
|
} else {
|
|
# If no event-aggregator attribute, then remove stale series if any.
|
|
delete $readings->{".ts"};
|
|
}
|
|
}
|
|
|
|
|
|
setReadingsVal($hash, $reading, $value,
|
|
$timestamp ? $timestamp : $hash->{".updateTimestamp"})
|
|
if($update_timestamp);
|
|
|
|
my $rv = "$reading: $value";
|
|
if($changed) {
|
|
if($reading eq "state") {
|
|
$rv = $value;
|
|
$hash->{CHANGEDWITHSTATE} = [];
|
|
}
|
|
addEvent($hash, $rv, $timestamp);
|
|
}
|
|
return $rv;
|
|
}
|
|
|
|
#
|
|
# this is a shorthand call
|
|
#
|
|
sub
|
|
readingsSingleUpdate($$$$;$)
|
|
{
|
|
my ($hash,$reading,$value,$dotrigger,$timestamp)= @_;
|
|
readingsBeginUpdate($hash);
|
|
my $rv = readingsBulkUpdate($hash, $reading, $value, undef, $timestamp);
|
|
readingsEndUpdate($hash,$dotrigger);
|
|
return $rv;
|
|
}
|
|
|
|
sub
|
|
readingsDelete($$)
|
|
{
|
|
my ($hash,$reading) = @_;
|
|
delete $hash->{READINGS}{$reading};
|
|
delete $hash->{OLDREADINGS}{$reading};
|
|
}
|
|
|
|
##############################################################################
|
|
#
|
|
# date and time routines
|
|
#
|
|
##############################################################################
|
|
|
|
sub
|
|
fhemTzOffset($)
|
|
{
|
|
# see http://stackoverflow.com/questions/2143528/whats-the-best-way-to-get-the-utc-offset-in-perl
|
|
my $t = shift;
|
|
my @l = localtime($t);
|
|
my @g = gmtime($t);
|
|
|
|
# the offset is positive if the local timezone is ahead of GMT, e.g. we get
|
|
# 2*3600 seconds for CET DST vs GMT
|
|
return 60*(($l[2] - $g[2] +
|
|
((($l[5] << 9)|$l[7]) <=> (($g[5] << 9)|$g[7])) * 24)*60 +
|
|
$l[1] - $g[1]);
|
|
}
|
|
|
|
sub
|
|
fhemTimeGm($$$$$$)
|
|
{
|
|
# see http://de.wikipedia.org/wiki/Unixzeit
|
|
my ($sec,$min,$hour,$mday,$month,$year) = @_;
|
|
|
|
# $mday= 1..
|
|
# $month= 0..11
|
|
# $year is year-1900
|
|
|
|
$year += 1900;
|
|
my $isleapyear= $year % 4 ? 0 : $year % 100 ? 1 : $year % 400 ? 0 : 1;
|
|
|
|
# Forum #38610
|
|
my $leapyears_date = int(($year-1)/4) -int(($year-1)/100) +int(($year-1)/400);
|
|
my $leapyears_1970 = int((1970 -1)/4) -int((1970 -1)/100) +int((1970 -1)/400);
|
|
my $leapyears = $leapyears_date - $leapyears_1970;
|
|
|
|
if ( $^O eq 'MacOS' ) {
|
|
$year -= 1904;
|
|
} else {
|
|
$year -= 1970; # the Unix Epoch
|
|
}
|
|
|
|
my @d = (0,31,59,90,120,151,181,212,243,273,304,334); # no leap day
|
|
# add one day in leap years if month is later than February
|
|
$mday++ if($month>1 && $isleapyear);
|
|
return $sec+60*($min+60*($hour+24*
|
|
($d[$month]+$mday-1+365*$year+$leapyears)));
|
|
}
|
|
|
|
sub
|
|
fhemTimeLocal($$$$$$) {
|
|
my $t= fhemTimeGm($_[0],$_[1],$_[2],$_[3],$_[4],$_[5]);
|
|
return $t-fhemTzOffset($t);
|
|
}
|
|
|
|
# compute the list of defined logical modules for a physical module
|
|
sub
|
|
computeClientArray($$)
|
|
{
|
|
my ($hash, $module) = @_;
|
|
my @a = ();
|
|
|
|
my @mRe = split(":", $hash->{Clients} ? $hash->{Clients}:$module->{Clients});
|
|
|
|
if($hash->{ClientsKeepOrder}) {
|
|
@a = grep { $modules{$_} && $modules{$_}{Match} } @mRe;
|
|
|
|
} else {
|
|
my @cmRe = map { qr/^$_$/ } @mRe; # 125292, precompile, speedup 5x for CUL
|
|
foreach my $m (sort { $modules{$a}{ORDER}.$a cmp $modules{$b}{ORDER}.$b }
|
|
grep { defined($modules{$_}{ORDER}) } keys %modules) {
|
|
foreach my $re (@cmRe) {
|
|
if($m =~ $re) {
|
|
push @a, $m if($modules{$m}{Match});
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
$hash->{".clientArray"} = \@a;
|
|
return \@a;
|
|
}
|
|
|
|
# http://perldoc.perl.org/perluniintro.html, UNICODE IN OLDER PERLS
|
|
sub
|
|
latin1ToUtf8($)
|
|
{
|
|
my ($s)= @_;
|
|
$s =~ s/([\x80-\xFF])/chr(0xC0|ord($1)>>6).chr(0x80|ord($1)&0x3F)/eg;
|
|
return $s;
|
|
}
|
|
|
|
sub
|
|
utf8ToLatin1($)
|
|
{
|
|
my ($s)= @_;
|
|
$s =~ s/([\xC2\xC3])([\x80-\xBF])/chr(ord($1)<<6&0xC0|ord($2)&0x3F)/eg;
|
|
return $s;
|
|
}
|
|
|
|
# replaces some common control chars by escape sequences
|
|
# in order to make logs more readable
|
|
sub
|
|
escapeLogLine($) {
|
|
my ($s)= @_;
|
|
|
|
# http://perldoc.perl.org/perlrebackslash.html
|
|
my %escSequences = (
|
|
'\a' => "\\a",
|
|
'\e' => "\\e",
|
|
'\f' => "\\f",
|
|
'\n' => "\\n",
|
|
'\r' => "\\r",
|
|
'\t' => "\\t",
|
|
);
|
|
|
|
$s =~ s/\\/\\\\/g;
|
|
foreach my $regex (keys %escSequences) {
|
|
$s =~ s/$regex/$escSequences{$regex}/g;
|
|
}
|
|
$s =~ s/([\000-\037])/sprintf("\\%03o", ord($1))/eg;
|
|
return $s;
|
|
}
|
|
|
|
sub
|
|
toJSON($)
|
|
{
|
|
my $val = shift;
|
|
|
|
if(not defined $val) {
|
|
return "null";
|
|
|
|
} elsif (length( do { no warnings "numeric"; $val & "" } )) {
|
|
return $val;
|
|
|
|
} elsif (not ref $val) {
|
|
$val =~ s/([\x00-\x1f\x22\x5c\x7f])/sprintf '\u%04x', ord($1)/ge;
|
|
|
|
return '"' . $val . '"';
|
|
|
|
} elsif (ref $val eq 'ARRAY') {
|
|
return '[' . join(',', map toJSON($_), @$val) . ']';
|
|
|
|
} elsif (ref $val eq 'HASH') {
|
|
return '{' . join(',',
|
|
map { toJSON($_).":".toJSON($val->{$_}) }
|
|
sort keys %$val) . '}';
|
|
|
|
} else {
|
|
return toJSON("toJSON: Cannot encode $val");
|
|
|
|
}
|
|
}
|
|
|
|
#############################
|
|
# will return a hash of name:value pairs. in is a json_string, prefix will be
|
|
# prepended to each name, map is a hash for mapping the names
|
|
sub
|
|
json2nameValue($;$$$$)
|
|
{
|
|
my ($in, $prefix, $map, $filter, $negFilter) = @_;
|
|
return if(!$in); # 122048
|
|
$prefix = "" if(!defined($prefix));
|
|
my %ret;
|
|
|
|
sub
|
|
lStr($) # extract a string
|
|
{
|
|
my ($t) = @_;
|
|
my $esc;
|
|
for(my $off = 1; $off < length($t); $off++){
|
|
my $s = substr($t,$off,1);
|
|
if($s eq '\\') {
|
|
$esc = !$esc;
|
|
} elsif($s eq '"' && !$esc) {
|
|
my $val = substr($t,1,$off-1);
|
|
if($val =~ m/\\u([0-9A-F]{4})/i) {
|
|
$val =~ s/\\u([0-9A-F]{4})/chr(hex($1))/gsie; # toJSON reverse
|
|
$val = Encode::encode("UTF-8", $val) if(!$unicodeEncoding); #128932
|
|
}
|
|
my %t = ( n =>"\n", '"'=>'"', '\\'=>'\\' );
|
|
$val =~ s/\\([n"\\])/$t{$1}/ge;
|
|
return (undef, $val, substr($t,$off+1));
|
|
} else {
|
|
$esc = 0;
|
|
}
|
|
}
|
|
return ('json2nameValue: no closing " found', "","");
|
|
}
|
|
|
|
sub
|
|
lObj($$$) # extract one object: {} or []
|
|
{
|
|
my ($t, $oc, $cc) = @_;
|
|
my $depth=1;
|
|
my ($esc, $inquote);
|
|
|
|
$inquote = 0;
|
|
for(my $off = 1; $off < length($t); $off++){
|
|
my $s = substr($t,$off,1);
|
|
if($s eq $cc && !$inquote) { # close character
|
|
$depth--;
|
|
return ("", substr($t,1,$off-1), substr($t,$off+1)) if(!$depth);
|
|
|
|
} elsif($s eq $oc && !$inquote) { # open character
|
|
$depth++;
|
|
|
|
} elsif($s eq '"' && !$esc) {
|
|
$inquote = !$inquote;
|
|
|
|
} elsif($s eq '\\') {
|
|
$esc = !$esc;
|
|
|
|
} else {
|
|
$esc = 0;
|
|
}
|
|
}
|
|
return ("json2nameValue: no closing $cc found", "", "");
|
|
}
|
|
|
|
sub
|
|
setVal($$$$)
|
|
{
|
|
my ($ret,$prefix,$name,$val) = @_;
|
|
$name = "$prefix$name";
|
|
$ret->{$name} = $val;
|
|
};
|
|
|
|
sub eObj($$$$$;$);
|
|
sub
|
|
eObj($$$$$;$)
|
|
{
|
|
my ($ret,$name,$val,$in,$prefix,$firstLevel) = @_;
|
|
my $err;
|
|
$prefix="" if(!$firstLevel);
|
|
|
|
if($val =~ m/^"/) {
|
|
($err, $val, $in) = lStr($val);
|
|
return ($err,undef) if($err);
|
|
setVal($ret, $prefix, $name, $val);
|
|
|
|
} elsif($val =~ m/^{/) { # }
|
|
($err, $val, $in) = lObj($val, '{', '}');
|
|
return ($err,undef) if($err);
|
|
|
|
my %r2;
|
|
my $in2 = $val;
|
|
while($in2 =~ m/^\s*"([^"]*)"\s*:\s*(.*)$/s) { # 125340
|
|
my ($name,$val) = ($1,$2);
|
|
$name =~ s/[^a-z0-9._\-\/]/_/gsi;
|
|
($err,$in2) = eObj(\%r2, $name, $val, $in2, $prefix);
|
|
return ($err,undef) if($err);
|
|
$in2 =~ s/^\s*,\s*//;
|
|
}
|
|
foreach my $k (keys %r2) {
|
|
setVal($ret, $prefix, $firstLevel ? $k : "${name}_$k", $r2{$k});
|
|
}
|
|
return ("error parsing (#1) '$in2'", undef) if($in2 !~ m/^\s*$/);
|
|
|
|
} elsif($val =~ m/^\[/) {
|
|
($err, $val, $in) = lObj($val, '[', ']');
|
|
return ($err,undef) if($err);
|
|
my $idx = 1;
|
|
$val =~ s/^\s*//;
|
|
while(defined($val) && $val ne "") {
|
|
($err,$val) = eObj($ret, $firstLevel ? "$prefix$idx" : $name."_$idx",
|
|
$val, $val, $prefix);
|
|
return ($err,undef) if($err);
|
|
$val =~ s/^\s*,\s*//;
|
|
$val =~ s/\s*$//;
|
|
$idx++;
|
|
}
|
|
|
|
} elsif($val =~ m/^((-?[0-9.]+)([eE][+-]?[0-9]+)?)(.*)$/s && # 125340
|
|
looks_like_number($1)) {
|
|
setVal($ret, $prefix, $name, $1);
|
|
$in = $4;
|
|
|
|
} elsif($val =~ m/^(true|false)(.*)$/s) {
|
|
setVal($ret, $prefix, $name, $1);
|
|
$in = $2;
|
|
|
|
} elsif($val =~ m/^(null|none)(.*)$/is) { # 139411
|
|
setVal($ret, $prefix, $name, undef);
|
|
$in = $2;
|
|
|
|
} else {
|
|
return ("error parsing (#2) '$val'", undef);
|
|
|
|
}
|
|
return (undef, $in);
|
|
}
|
|
|
|
$in =~ s/^\s+//;
|
|
my ($err, undef) = eObj(\%ret, "", $in, "", $prefix, 1);
|
|
return { json2nameValueErrorText=>$err, json2nameValueInput=>$in } if($err);
|
|
|
|
return \%ret if(!defined($map) && !defined($filter));
|
|
$map = eval $map if($map && !ref($map)); # passing hash through AnalyzeCommand
|
|
|
|
my %ret2;
|
|
for my $name (keys %ret) {
|
|
next if($negFilter && $name =~ m/$negFilter/);
|
|
my $oname = $name;
|
|
if(defined($map->{$name})) {
|
|
next if(!$map->{$name});
|
|
$name = $map->{$name};
|
|
}
|
|
next if($filter && $name !~ m/$filter/);
|
|
$ret2{$name} = $ret{$oname};
|
|
}
|
|
return \%ret2;
|
|
}
|
|
|
|
# add certain values to the key. Used to postprocess json2nameValue, where
|
|
# the input is of the form [{"name":"NAME","value":"Value"}], with
|
|
# hashKeyRename(json2nameValue($in), "^([0-9]+)_name:(.*)","^([0-9]+)");
|
|
sub
|
|
hashKeyRename($$$)
|
|
{
|
|
my ($hash, $r1, $r2) = @_;
|
|
my (%repl, %ret);
|
|
for my $k (keys %{$hash}) {
|
|
$repl{$1} = $2 if(defined($hash->{$k}) &&
|
|
"$k:$hash->{$k}" =~ m/$r1/ && defined($1) && defined($2));
|
|
}
|
|
for my $k (keys %{$hash}) {
|
|
my $val = $hash->{$k};
|
|
next if($k !~ m/$r2/ || !defined($repl{$1}));
|
|
$k =~ s/$r2/$repl{$1}/;
|
|
$ret{$k} = $val;
|
|
}
|
|
return \%ret;
|
|
}
|
|
|
|
# generate readings from the json string (parsed by json2reading) for $hash
|
|
sub
|
|
json2reading($$;$$$$)
|
|
{
|
|
my ($hash, $json, $prefix, $map, $postProcess, $filter) = @_;
|
|
|
|
$hash = $defs{$hash} if(ref($hash) ne "HASH");
|
|
return "json2reading: first arg is not a FHEM device"
|
|
if(!$hash || ref $hash ne "HASH" || !$hash->{TYPE});
|
|
|
|
my $ret = json2nameValue($json, $prefix, $map, $filter);
|
|
if($postProcess) {
|
|
$ret = eval($postProcess);
|
|
Log 1, $@ if($@);
|
|
}
|
|
if($ret && ref $ret eq "HASH") {
|
|
readingsBeginUpdate($hash);
|
|
foreach my $k (keys %{$ret}) {
|
|
readingsBulkUpdate($hash, makeReadingName($k), $ret->{$k});
|
|
}
|
|
readingsEndUpdate($hash, 1);
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
|
|
|
|
sub
|
|
Debug($) {
|
|
my $msg= shift;
|
|
stacktrace() if(AttrNum('global','stacktrace',0) == 1);
|
|
Log 1, "DEBUG>" . $msg;
|
|
}
|
|
|
|
sub
|
|
addToWritebuffer($$@)
|
|
{
|
|
my ($hash, $txt, $callback, $nolimit) = @_;
|
|
|
|
if(!defined($hash->{FD})) {
|
|
my $n = $hash->{NAME};
|
|
Log 1, "ERROR: addToWritebuffer for $n without FD";
|
|
Log 1, "callstack:".stacktraceAsString(1);
|
|
Log 1, "FD closed in ".$hash->{stacktrace} if($hash->{stacktrace});
|
|
delete($defs{$n});
|
|
delete($attr{$n});
|
|
return;
|
|
}
|
|
if($hash->{isChild}) { # Wont go to the main select in a forked process
|
|
TcpServer_WriteBlocking( $hash, $txt );
|
|
if($callback) {
|
|
no strict "refs";
|
|
my $ret = &{$callback}($hash);
|
|
use strict "refs";
|
|
}
|
|
return;
|
|
}
|
|
|
|
$hash->{WBCallback} = $callback;
|
|
if(!defined($hash->{$wbName})) {
|
|
$hash->{$wbName} = $txt;
|
|
} elsif($nolimit || length($hash->{$wbName}) < 1024000) {
|
|
$hash->{$wbName} .= $txt;
|
|
} else {
|
|
return 0;
|
|
}
|
|
|
|
return 1; # success
|
|
}
|
|
|
|
# Faster than createNtfyHash
|
|
sub
|
|
removeFromNtfyHash($)
|
|
{
|
|
my ($toDel) = @_;
|
|
return if(!$defs{$toDel} ||
|
|
!$defs{$toDel}{TYPE} ||
|
|
!$modules{$defs{$toDel}{TYPE}}{NotifyFn});
|
|
foreach my $d ( keys %ntfyHash) {
|
|
my @a = grep { $_ !~ m/^$toDel$/ } @{$ntfyHash{$d}};
|
|
$ntfyHash{$d} = \@a;
|
|
}
|
|
}
|
|
|
|
|
|
# Note: always executed after ntfyHash = (); slow for large installations!
|
|
sub
|
|
createNtfyHash()
|
|
{
|
|
Log 5, "createNotifyHash";
|
|
my @ntfyList = sort { $defs{$a}{NTFY_ORDER} cmp $defs{$b}{NTFY_ORDER} }
|
|
grep { $defs{$_}{NTFY_ORDER} &&
|
|
$defs{$_}{TYPE} &&
|
|
!$defs{$_}{disableNotifyFn} &&
|
|
$modules{$defs{$_}{TYPE}}{NotifyFn} } keys %defs;
|
|
my %d2a_cache;
|
|
%ntfyHash = ("*" => []);
|
|
foreach my $d (@ntfyList) {
|
|
my $ndl = $attr{$d}{overrideNotifydev};
|
|
$ndl = $defs{$d}{NOTIFYDEV} if(!$ndl);
|
|
next if(!$ndl);
|
|
my @ndlarr;
|
|
if($d2a_cache{$ndl}) {
|
|
@ndlarr = @{$d2a_cache{$ndl}};
|
|
} else {
|
|
@ndlarr = devspec2array($ndl);
|
|
if(@ndlarr > 1) {
|
|
my %h = map { $_ => 1 } @ndlarr;
|
|
@ndlarr = keys %h;
|
|
}
|
|
$d2a_cache{$ndl} = \@ndlarr;
|
|
}
|
|
map { $ntfyHash{$_} = [] } @ndlarr;
|
|
}
|
|
|
|
my @nhk = keys %ntfyHash;
|
|
foreach my $d (@ntfyList) {
|
|
my $ndl = $attr{$d}{overrideNotifydev};
|
|
$ndl = $defs{$d}{NOTIFYDEV} if(!$ndl);
|
|
my $arr = ($ndl ? $d2a_cache{$ndl} : \@nhk);
|
|
map { push @{$ntfyHash{$_}}, $d } @{$arr};
|
|
}
|
|
}
|
|
|
|
# Used for debugging
|
|
sub
|
|
notifyRegexpCheck($)
|
|
{
|
|
join("\n", map {
|
|
if($_ !~ m/^\(?([A-Za-z0-9\.\_]+(?:\.[\+\*])?)(?::.*)?\)?$/) {
|
|
"$_: no match (ignored)"
|
|
} elsif($defs{$1}) {
|
|
"$_: device $1 (OK)";
|
|
} else {
|
|
my @ds = devspec2array($1);
|
|
if($ds[0] ne $1) {
|
|
"$_: devspec ".join(",",@ds)." (OK)";
|
|
} else {
|
|
"$_: unknown (ignored)";
|
|
}
|
|
}
|
|
} split(/\|/, $_[0]));
|
|
}
|
|
|
|
sub
|
|
notifyRegexpChanged($$;$)
|
|
{
|
|
my ($hash, $re, $disableNotifyFn) = @_;
|
|
|
|
%ntfyHash = ();
|
|
if($disableNotifyFn) {
|
|
delete($hash->{NOTIFYDEV});
|
|
$hash->{disableNotifyFn}=1;
|
|
return;
|
|
}
|
|
delete($hash->{disableNotifyFn});
|
|
my @list2 = split(/\|/, $re);
|
|
my @list = grep { m/./ } # Forum #62369
|
|
map { (m/^\(?([A-Za-z0-9\.\_]+(?:\.[\+\*])?)(?::.*)?\)?$/ &&
|
|
($defs{$1} || devspec2array($1) ne $1)) ? $1 : ""} @list2;
|
|
if(@list && int(@list) == int(@list2)) {
|
|
my %h = map { $_ => 1 } @list;
|
|
@list = keys %h; # remove duplicates
|
|
$hash->{NOTIFYDEV} = join(",", @list);
|
|
} else {
|
|
delete($hash->{NOTIFYDEV});
|
|
}
|
|
}
|
|
|
|
sub
|
|
setDisableNotifyFn($$)
|
|
{
|
|
my ($hash, $doit) = @_;
|
|
|
|
if($doit) {
|
|
delete($hash->{NOTIFYDEV});
|
|
$hash->{disableNotifyFn} = 1
|
|
} else {
|
|
delete($hash->{disableNotifyFn});
|
|
}
|
|
%ntfyHash = ();
|
|
}
|
|
|
|
sub
|
|
setNotifyDev($$)
|
|
{
|
|
my ($hash, $ntfydev) = @_;
|
|
|
|
if($ntfydev) {
|
|
$hash->{NOTIFYDEV} = $ntfydev;
|
|
} else {
|
|
delete($hash->{NOTIFYDEV});
|
|
}
|
|
%ntfyHash = ();
|
|
}
|
|
|
|
sub
|
|
configDBUsed()
|
|
{
|
|
return ($attr{global}{configfile} eq 'configDB');
|
|
}
|
|
|
|
sub
|
|
FileRead($)
|
|
{
|
|
my ($param) = @_;
|
|
my ($err, @ret, $fileName, $forceType);
|
|
|
|
$forceType = "" if(!defined($forceType));
|
|
if(ref($param) eq "HASH") {
|
|
$fileName = $param->{FileName};
|
|
$forceType = lc($param->{ForceType}) if($param->{ForceType});
|
|
} else {
|
|
$fileName = $param;
|
|
}
|
|
|
|
if(configDBUsed() && $forceType ne "file") {
|
|
($err, @ret) = cfgDB_FileRead($fileName);
|
|
|
|
} else {
|
|
my $FH;
|
|
if(open($FH, $fileName)) {
|
|
binmode($FH, ":encoding(UTF-8)") if($unicodeEncoding);
|
|
@ret = <$FH>;
|
|
close($FH);
|
|
chomp(@ret);
|
|
} else {
|
|
$err = "Can't open $fileName: $!";
|
|
}
|
|
|
|
}
|
|
|
|
return ($err, @ret);
|
|
}
|
|
|
|
sub
|
|
FileWrite($@)
|
|
{
|
|
my ($param, @rows) = @_;
|
|
my ($err, @ret, $fileName, $forceType, $nl);
|
|
|
|
if(ref($param) eq "HASH") {
|
|
$fileName = $param->{FileName};
|
|
$forceType = $param->{ForceType};
|
|
$nl = $param->{NoNL} ? "" : "\n";
|
|
} else {
|
|
$fileName = $param;
|
|
$nl = "\n";
|
|
}
|
|
$forceType = "" if(!defined($forceType));
|
|
|
|
if(configDBUsed() && $forceType ne "file") {
|
|
return cfgDB_FileWrite($fileName, @rows);
|
|
|
|
} else {
|
|
my $FH;
|
|
if(open($FH, ">$fileName")) {
|
|
binmode($FH);
|
|
binmode($FH, ":encoding(UTF-8)") if($unicodeEncoding);
|
|
foreach my $l (@rows) {
|
|
print $FH $l,$nl;
|
|
}
|
|
close($FH);
|
|
return undef;
|
|
|
|
} else {
|
|
return "Can't open $fileName: $!";
|
|
|
|
}
|
|
}
|
|
}
|
|
|
|
sub
|
|
FileDelete($)
|
|
{
|
|
my ($param) = @_;
|
|
my ($fileName, $forceType);
|
|
if(ref($param) eq "HASH") {
|
|
$fileName = $param->{FileName};
|
|
$forceType = $param->{ForceType};
|
|
} else {
|
|
$fileName = $param;
|
|
}
|
|
$forceType //= '';
|
|
if(configDBUsed() && lc($forceType) ne "file") {
|
|
my $ret = _cfgDB_Filedelete($fileName);
|
|
return ($ret ? undef : "$fileName: _cfgDB_Filedelete failed");
|
|
} else {
|
|
my $ret = unlink($fileName);
|
|
return ($ret ? undef : "$fileName: $!");
|
|
}
|
|
}
|
|
|
|
sub
|
|
getUniqueId()
|
|
{
|
|
return $globalUniqueID if($globalUniqueID);
|
|
my ($err, $uniqueID) = getKeyValue("uniqueID");
|
|
if(defined($uniqueID)) {
|
|
$uniqueID =~ s/[^0-9a-f]//g;
|
|
if($uniqueID && length($uniqueID) == 32) {
|
|
$globalUniqueID = $uniqueID;
|
|
return $uniqueID;
|
|
}
|
|
}
|
|
$uniqueID = createUniqueId();
|
|
setKeyValue("uniqueID", $uniqueID);
|
|
$globalUniqueID = $uniqueID;
|
|
return $uniqueID;
|
|
}
|
|
|
|
my $srandUsed;
|
|
sub
|
|
createUniqueId()
|
|
{
|
|
my $uniqueID;
|
|
srand(gettimeofday()) if(!$srandUsed);
|
|
$srandUsed = 1;
|
|
$uniqueID = join "",map { unpack "H*", chr(rand(256)) } 1..16;
|
|
return $uniqueID;
|
|
}
|
|
|
|
sub
|
|
getKeyValue($)
|
|
{
|
|
my ($key) = @_;
|
|
my $fName = AttrVal("global", "keyFileName", "uniqueID");
|
|
$fName =~ s/\.\.//g;
|
|
$fName = $attr{global}{modpath}."/FHEM/FhemUtils/$fName";
|
|
my ($err, @l) = FileRead($fName);
|
|
return ($err, undef) if($err);
|
|
for my $l (@l) {
|
|
return (undef, $1) if($l =~ m/^$key:(.*)/);
|
|
}
|
|
return (undef, undef);
|
|
}
|
|
|
|
# Use an undefined value to delete the key
|
|
sub
|
|
setKeyValue($$)
|
|
{
|
|
my ($key,$value) = @_;
|
|
return "setKeyValue: invalid key: $key"
|
|
if(!defined($key) || $key =~ m/\n/s);
|
|
return "setKeyValue: invalid value: $value"
|
|
if($value && $value =~ m/\n/s);
|
|
my $fName = AttrVal("global", "keyFileName", "uniqueID");
|
|
$fName =~ s/\.\.//g;
|
|
$fName = $attr{global}{modpath}."/FHEM/FhemUtils/$fName";
|
|
my ($err, @old) = FileRead($fName);
|
|
my @new;
|
|
if($err) {
|
|
push(@new, "# This file is auto generated.",
|
|
"# Please do not modify, move or delete it.",
|
|
"");
|
|
@old = ();
|
|
}
|
|
|
|
my $fnd;
|
|
foreach my $l (@old) {
|
|
if($l =~ m/^$key:/) {
|
|
$fnd = 1;
|
|
push @new, "$key:$value" if(defined($value));
|
|
} else {
|
|
push @new, $l;
|
|
}
|
|
}
|
|
push @new, "$key:$value" if(!$fnd && defined($value));
|
|
|
|
return FileWrite($fName, @new);
|
|
}
|
|
|
|
sub
|
|
addStructChange($$$)
|
|
{
|
|
my ($cmd, $dev, $param) = @_;
|
|
|
|
return if(!$init_done);
|
|
return if(defined($dev) &&
|
|
(!$defs{$dev} || $defs{$dev}{TEMPORARY} || $defs{$dev}{VOLATILE}));
|
|
|
|
$lastDefChange++;
|
|
my ($mr,$ml) = split(" ", AttrVal('global', 'maxChangeLog', 10));
|
|
shift @structChangeHist if(@structChangeHist > $mr - 1);
|
|
$ml = 40 if(!defined($ml));
|
|
$param = substr($param, 0, $ml)."..." if(length($param) > $ml);
|
|
push @structChangeHist, "$cmd $param";
|
|
}
|
|
|
|
sub
|
|
fhemFork()
|
|
{
|
|
my $pid = fork;
|
|
if(!defined($pid)) {
|
|
Log 1, "Cannot fork: $!";
|
|
stacktrace() if($attr{global}{stacktrace});
|
|
return undef;
|
|
}
|
|
|
|
return $pid if($pid);
|
|
|
|
# Child here
|
|
# Close FDs as we cannot restart FHEM if child keeps TCP Serverports open
|
|
foreach my $d (sort keys %defs) {
|
|
my $h = $defs{$d};
|
|
$h->{DBH}->{InactiveDestroy} = 1
|
|
if($h->{DBH} && $h->{TYPE} eq 'DbLog'); #Forum #43271
|
|
TcpServer_Close($h) if($h->{SERVERSOCKET});
|
|
if($h->{DeviceName}) {
|
|
require "DevIo.pm";
|
|
DevIo_CloseDev($h,1);
|
|
}
|
|
}
|
|
$SIG{CHLD} = 'DEFAULT'; # Forum #50898
|
|
$fhemForked = 1;
|
|
return 0;
|
|
}
|
|
|
|
# Return the next element from the string (list) for each consecutive call.
|
|
# The index for the next call is stored in the device hash
|
|
sub
|
|
Each($$;$) # can be used e.g. in at, Forum #40022
|
|
{
|
|
my ($dev, $string, $sep) = @_;
|
|
return "" if(!$defs{$dev});
|
|
my $idx = ($defs{$dev}{EACH_INDEX} ? $defs{$dev}{EACH_INDEX} : 0);
|
|
$sep = "," if(!$sep);
|
|
my @arr = split($sep, $string);
|
|
|
|
$idx = 0 if(@arr <= $idx);
|
|
$defs{$dev}{EACH_INDEX} = $idx+1;
|
|
|
|
return $arr[$idx];
|
|
}
|
|
|
|
##################
|
|
# Return 1 if Authorized, else 0
|
|
# Note: AuthorizeFn's returning 1 are not stackable.
|
|
sub
|
|
Authorized($$$;$)
|
|
{
|
|
my ($cl, $type, $arg, $silent) = @_;
|
|
|
|
return 1 if(!$init_done || !$cl || !$cl->{SNAME}); # Safeguarding
|
|
RefreshAuthList() if($auth_refresh);
|
|
my $sname = $cl->{SNAME};
|
|
my $verbose = AttrVal($sname, "verbose", 1); # Speedup?
|
|
|
|
foreach my $a (@authorize) {
|
|
my $r = CallFn($a, "AuthorizeFn", $defs{$a}, $cl, $type, $arg, $silent);
|
|
if($verbose >= 4 && !$silent) {
|
|
Log3 $sname, 4, "authorize $sname/$type/$arg: $a returned ".
|
|
($r == 0 ? "dont care" : $r == 1 ? "allowed" : "prohibited");
|
|
}
|
|
return 1 if($r == 1);
|
|
return 0 if($r == 2);
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
##################
|
|
# Return 0 if not needed, 1 if authenticated, 2 if authentication failed
|
|
# Loop until one Authenticate is ok
|
|
sub
|
|
Authenticate($$)
|
|
{
|
|
my ($cl, $arg) = @_;
|
|
|
|
return 1 if(!$init_done || !$cl || !$cl->{SNAME}); # Safeguarding
|
|
RefreshAuthList() if($auth_refresh);
|
|
|
|
my $needed = 0;
|
|
foreach my $a (@authenticate) {
|
|
my $r = CallFn($a, "AuthenticateFn", $defs{$a}, $cl, $arg);
|
|
$needed = $r if($r);
|
|
last if($r == 1);
|
|
}
|
|
|
|
if($needed == 2 && $cl->{NAME} ne "SecurityCheck") {
|
|
my $adb = $cl->{AuthenticationDeniedBy};
|
|
if($adb) {
|
|
my $au = $cl->{AuthenticatedUser};
|
|
Log3 $adb, 3, "Login denied ".
|
|
($au ? "for user >$au< ":"")."via $cl->{NAME}";
|
|
}
|
|
} else {
|
|
delete $cl->{AuthenticationDeniedBy};
|
|
}
|
|
|
|
return $needed;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
RefreshAuthList()
|
|
{
|
|
@authorize = ();
|
|
@authenticate = ();
|
|
|
|
foreach my $d (sort keys %defs) {
|
|
my $h = $defs{$d};
|
|
next if(!$h->{TYPE} || !$modules{$h->{TYPE}});
|
|
push @authorize, $d if($modules{$h->{TYPE}}{AuthorizeFn});
|
|
push @authenticate, $d if($modules{$h->{TYPE}}{AuthenticateFn});
|
|
}
|
|
$auth_refresh = 0;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
perlSyntaxCheck($%)
|
|
{
|
|
my ($exec, %specials)= @_;
|
|
|
|
my $psc = AttrVal("global", "perlSyntaxCheck", ($featurelevel>5.7) ? 1 : 0);
|
|
return undef if(!$psc || !$init_done);
|
|
|
|
my ($arr, $hash) = parseParams($exec, ';');
|
|
$arr = [ $exec ] if(!@$arr); # temporary bugfix
|
|
for my $cmd (@{$arr}) {
|
|
next if($cmd !~ m/^\s*{/); # } for match
|
|
$specials{__UNIQUECMD__}=1;
|
|
$cmd = EvalSpecials("{return undef; $cmd}", %specials);
|
|
my $r = AnalyzePerlCommand(undef, $cmd);
|
|
return $r if($r);
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
#####################################
|
|
sub
|
|
parseParams($;$$$)
|
|
{
|
|
my($cmd, $separator, $joiner, $keyvalueseparator) = @_;
|
|
$separator = ' ' if(!$separator);
|
|
$joiner = $separator if(!$joiner); # needed if separator is a regexp
|
|
$keyvalueseparator = '=' if(!$keyvalueseparator);
|
|
my(@a, %h);
|
|
return(\@a, \%h) if(!defined($cmd));
|
|
|
|
my @params;
|
|
if( ref($cmd) eq 'ARRAY' ) {
|
|
@params = @{$cmd};
|
|
} else {
|
|
@params = split($separator, $cmd);
|
|
}
|
|
|
|
while (@params) {
|
|
my $param = shift(@params);
|
|
next if($param eq "");
|
|
my ($key, $value) = split( $keyvalueseparator, $param, 2 );
|
|
|
|
if( !defined( $value ) ) {
|
|
$value = $key;
|
|
$key = undef;
|
|
|
|
# the key can not start with a { -> it must be a perl expression # vim:}
|
|
} elsif( $key =~ m/^\s*{/ ) { # for vim: }
|
|
$value = $param;
|
|
$key = undef;
|
|
}
|
|
|
|
#collect all parts until the closing ' or "
|
|
while( $param && $value =~ m/^('|")/ && $value !~ m/$1$/ ) {
|
|
my $next = shift(@params);
|
|
last if( !defined($next) );
|
|
$value .= $joiner . $next;
|
|
}
|
|
#remove matching ' or " from the start and end
|
|
if( $value =~ m/^('|")/ && $value =~ m/$1$/ ) {
|
|
$value =~ s/^.(.*).$/$1/;
|
|
}
|
|
|
|
#collect all parts until opening { and closing } are matched
|
|
if( $value =~ m/^\s*{/ ) { # } for match
|
|
my $count = 0;
|
|
for my $i (0..length($value)-1) {
|
|
my $c = substr($value, $i, 1);
|
|
++$count if( $c eq '{' );
|
|
--$count if( $c eq '}' );
|
|
}
|
|
|
|
while( $param && $count != 0 ) {
|
|
my $next = shift(@params);
|
|
last if( !defined($next) );
|
|
$value .= $joiner . $next;
|
|
|
|
for my $i (0..length($next)-1) {
|
|
my $c = substr($next, $i, 1);
|
|
++$count if( $c eq '{' );
|
|
--$count if( $c eq '}' );
|
|
}
|
|
}
|
|
}
|
|
|
|
if( defined($key) ) {
|
|
$h{$key} = $value;
|
|
} else {
|
|
push @a, $value;
|
|
}
|
|
|
|
}
|
|
return(\@a, \%h);
|
|
}
|
|
|
|
# get "Porbably Associated With" list for a devicename
|
|
sub
|
|
getPawList($)
|
|
{
|
|
my ($d) = @_;
|
|
my $h = $defs{$d};
|
|
my @dob;
|
|
my $daw = ReadingsVal($d, ".associatedWith", ""); # 103095
|
|
foreach my $dn (sort keys %defs) {
|
|
next if(!$dn || $dn eq $d);
|
|
my $dh = $defs{$dn};
|
|
if(($dh->{DEF} && $dh->{DEF} =~ m/\b$d\b/) ||
|
|
(ReadingsVal($dn, ".associatedWith", "") =~ m/\b$d\b/) ||
|
|
($h->{DEF} && $h->{DEF} =~ m/\b$dn\b/) ||
|
|
$daw =~ m/\b$dn\b/) {
|
|
push(@dob, $dn);
|
|
}
|
|
}
|
|
my $aw = ReadingsVal($d, "associatedWith", ""); # Explicit link
|
|
push(@dob, grep { $defs{$_} } split("[ ,]",$aw)) if($aw);
|
|
return @dob;
|
|
}
|
|
|
|
sub
|
|
goodDeviceName($)
|
|
{
|
|
my ($name) = @_;
|
|
return ($name && $name =~ m/^[a-z0-9._]*$/i);
|
|
}
|
|
|
|
sub
|
|
makeDeviceName($) # Convert non-valid characters to _
|
|
{
|
|
my ($name) = @_;
|
|
$name = "UNDEFINED" if(!defined($name));
|
|
$name =~ s/[^a-z0-9._]/_/gi;
|
|
return $name;
|
|
}
|
|
|
|
sub
|
|
goodReadingName($)
|
|
{
|
|
my ($name) = @_;
|
|
return undef if(!$name);
|
|
return ($name =~ m/^[a-z0-9._\-\/]+$/i ||
|
|
$name =~ m/^\.[^\s]*$/);
|
|
}
|
|
|
|
sub
|
|
makeReadingName($) # Convert non-valid characters to _
|
|
{
|
|
my ($name) = @_;
|
|
$name = "UNDEFINED" if(!defined($name));
|
|
if($name =~ m/^\./) {
|
|
$name =~ s/\s/_/g;
|
|
return $name;
|
|
}
|
|
my %umlaut = ( '\xc3\xa4'=>'ae',
|
|
'\xc3\xb6'=>'oe',
|
|
'\xc3\xbc'=>'ue',
|
|
'\xc3\x9f'=>'ss');
|
|
map { $name =~ s/$_/$umlaut{$_}/g } keys %umlaut;
|
|
$name =~ s/[^a-z0-9._\-\/]/_/gi;
|
|
return $name;
|
|
}
|
|
|
|
sub
|
|
computeAlignTime($$@)
|
|
{
|
|
my ($timeSpec, $alignSpec, $triggertime) = @_; # triggertime is now if absent
|
|
|
|
my ($alErr, $alHr, $alMin, $alSec, undef) = GetTimeSpec($alignSpec);
|
|
return ("alignTime: $alErr", undef) if($alErr);
|
|
|
|
my ($tmErr, $hr, $min, $sec, undef) = GetTimeSpec($timeSpec);
|
|
return ("timeSpec: $tmErr", undef) if($alErr);
|
|
|
|
my $now = int(gettimeofday());
|
|
my $alTime = ($alHr*60+$alMin)*60+$alSec;
|
|
my $step = ($hr*60+$min)*60+$sec;
|
|
my $ttime = ($triggertime ? int($triggertime) : $now);
|
|
my $off = (($ttime+fhemTzOffset($now)) % 86400) - 86400;
|
|
while($off < $alTime) {
|
|
$off += $step;
|
|
}
|
|
$ttime += ($alTime-$off);
|
|
$ttime += $step if($ttime < $now);
|
|
return (undef, $ttime);
|
|
}
|
|
|
|
############################
|
|
my %restoreDir_dirs;
|
|
sub
|
|
restoreDir_mkDir($$$)
|
|
{
|
|
my ($root, $dir, $isFile) = @_;
|
|
if($isFile) { # Delete the file Component
|
|
$dir =~ m,^(.*)/([^/]*)$,;
|
|
$dir = $1;
|
|
$dir = "" if(!defined($dir)); # file in .
|
|
}
|
|
return if($restoreDir_dirs{$dir});
|
|
$restoreDir_dirs{$dir} = 1;
|
|
my @p = split("/", $dir);
|
|
for(my $i = 0; $i < int(@p); $i++) {
|
|
my $path = "$root/".join("/", @p[0..$i]);
|
|
if(!-d $path) {
|
|
mkdir $path;
|
|
Log 4, "MKDIR $root/".join("/", @p[0..$i]);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub
|
|
restoreDir_rmTree($)
|
|
{
|
|
my ($dir) = @_;
|
|
|
|
my $dh;
|
|
if(!opendir($dh, $dir)) {
|
|
Log 1, "opendir $dir: $!";
|
|
return;
|
|
}
|
|
my @files = grep { $_ ne "." && $_ ne ".." } readdir($dh);
|
|
closedir($dh);
|
|
|
|
foreach my $f (@files) {
|
|
if(-d "$dir/$f") {
|
|
restoreDir_rmTree("$dir/$f");
|
|
} else {
|
|
Log 4, "rm $dir/$f";
|
|
if(!unlink("$dir/$f")) {
|
|
Log 1, "rm $dir/$f failed: $!";
|
|
}
|
|
}
|
|
}
|
|
Log 4, "rmdir $dir";
|
|
if(!rmdir($dir)) {
|
|
Log 1, "rmdir $dir failed: $!";
|
|
}
|
|
}
|
|
|
|
sub
|
|
restoreDir_init(;$)
|
|
{
|
|
my ($subDir) = @_;
|
|
my $root = $attr{global}{modpath};
|
|
|
|
my $nDirs = AttrVal("global","restoreDirs", 3);
|
|
if($nDirs !~ m/^\d+$/ || $nDirs < 0) {
|
|
Log 1, "invalid restoreDirs value $nDirs, setting it to 3";
|
|
$nDirs = 3;
|
|
}
|
|
return "" if($nDirs == 0);
|
|
|
|
my $rdName = "restoreDir";
|
|
$rdName .= "/$subDir" if($subDir);
|
|
my @t = localtime(gettimeofday());
|
|
my $restoreDir = sprintf("$rdName/%04d-%02d-%02d",
|
|
$t[5]+1900, $t[4]+1, $t[3]);
|
|
Log 1, "MKDIR $restoreDir" if(! -d "$root/restoreDir");
|
|
restoreDir_mkDir($root, $restoreDir, 0);
|
|
|
|
if(!opendir(DH, "$root/$rdName")) {
|
|
Log 1, "opendir $root/$rdName: $!";
|
|
return "";
|
|
}
|
|
my @oldDirs = sort grep { $_ =~ m/^20\d\d-\d\d-\d\d/ } readdir(DH);
|
|
closedir(DH);
|
|
while(int(@oldDirs) > $nDirs) {
|
|
my $dir = "$root/$rdName/". shift(@oldDirs);
|
|
next if($dir =~ m/$restoreDir/); # Just in case
|
|
Log 1, "RMDIR: $dir";
|
|
restoreDir_rmTree($dir);
|
|
}
|
|
|
|
return $restoreDir;
|
|
}
|
|
|
|
sub
|
|
restoreDir_saveFile($$)
|
|
{
|
|
my($restoreDir, $fName) = @_;
|
|
|
|
return if(!$restoreDir || !$fName);
|
|
|
|
if($^O eq "MSWin32") { # Forum #110071
|
|
$fName =~ s,^.:,,g;
|
|
$fName =~ s,\\,/,g;
|
|
}
|
|
|
|
my $root = $attr{global}{modpath};
|
|
restoreDir_mkDir($root, "$restoreDir/$fName", 1);
|
|
if(!copy($fName, "$root/$restoreDir/$fName")) {
|
|
Log 1, "copy $fName $root/$restoreDir/$fName failed:$!";
|
|
}
|
|
}
|
|
|
|
sub
|
|
SecurityCheck()
|
|
{
|
|
my @fnd;
|
|
return if(AttrVal("global", "disableFeatures", "") =~ m/\bsecurityCheck\b/i);
|
|
foreach my $sdev (keys %defs) {
|
|
next if($defs{$sdev}{TEMPORARY});
|
|
my $type = $defs{$sdev}{TYPE};
|
|
next if(!$modules{$type}{CanAuthenticate});
|
|
my $hash = { SNAME=>$sdev, TYPE=>$type, NAME=>"SecurityCheck"};
|
|
push(@fnd, " $sdev is not password protected")
|
|
if(!Authenticate($hash, undef));
|
|
}
|
|
if(@fnd) {
|
|
push @fnd, "";
|
|
my @l = devspec2array("TYPE=allowed");
|
|
if(@l) {
|
|
push @fnd, "Protect this FHEM installation by ".
|
|
"configuring the allowed device $l[0]";
|
|
} else {
|
|
push @fnd, "Protect this FHEM installation by ".
|
|
"defining an allowed device with define allowed allowed";
|
|
}
|
|
}
|
|
|
|
if($^O !~ m/Win/ && $<==0) {
|
|
push(@fnd, "Running with root privileges is discouraged.")
|
|
}
|
|
|
|
if(@fnd) {
|
|
unshift(@fnd, "SecurityCheck:");
|
|
push(@fnd, "You can disable this message with attr global motd none");
|
|
$defs{global}{init_errors} =~ s/SecurityCheck:.*motd none//s;
|
|
$defs{global}{init_errors} .= join("\n", @fnd);
|
|
}
|
|
}
|
|
|
|
#
|
|
sub genUUID()
|
|
{
|
|
srand(gettimeofday()) if(!$srandUsed);
|
|
$srandUsed = 1;
|
|
my $uuid = sprintf("%08x-f33f-%s-%s-%s", time(), substr(getUniqueId(),-4),
|
|
join("",map { unpack "H*", chr(rand(256)) } 1..2),
|
|
join("",map { unpack "H*", chr(rand(256)) } 1..8));
|
|
$fuuidHash{$uuid} = 1;
|
|
return $uuid;
|
|
}
|
|
|
|
sub
|
|
IsWe(;$$)
|
|
{
|
|
my ($when, $wday) = @_;
|
|
|
|
my $dt = ($when && $when =~ m/^((\d{4})-)?([01]\d)-([0-3]\d)$/);
|
|
$when = "state" if(!$when ||
|
|
($when !~ m/^(yesterday|today|tomorrow)$/ && !$dt));
|
|
if(!defined($wday)) {
|
|
if($dt) {
|
|
my ($y,$m,$d) = ($2 ? $2-1900 : (localtime())[5], $3-1, $4);
|
|
$wday = (localtime(mktime(1,1,1,$d,$m,$y,0,0,-1)))[6];
|
|
} else {
|
|
$wday = (localtime(gettimeofday()))[6];
|
|
}
|
|
}
|
|
|
|
my ($we, $wf);
|
|
foreach my $h2we (split(",", AttrVal("global", "holiday2we", ""))) {
|
|
my $b = $dt ? CommandGet(undef,"$h2we $when") : ReadingsVal($h2we,$when,0);
|
|
if($b && $b ne "none") {
|
|
return 0 if($h2we eq "noWeekEnd");
|
|
$we = 1 if($b && $b ne "none");
|
|
}
|
|
$wf = 1 if($h2we eq "weekEnd");
|
|
}
|
|
|
|
if(!$wf && !$we) {
|
|
$we = ($when eq "yesterday" ? ($wday==0 || $wday==1) :
|
|
($when ne "tomorrow" ? ($wday==6 || $wday==0) :
|
|
($wday==5 || $wday==6))); # tomorrow
|
|
}
|
|
return $we ? 1 : 0;
|
|
}
|
|
|
|
sub
|
|
applyGlobalAttrFromEnv()
|
|
{
|
|
while(my ($k,$v)= each %{$globalAttrFromEnv}) {
|
|
Log 3, "From the FHEM_GLOBALATTR environment: attr global $k $v";
|
|
CommandAttr(undef, "global $k $v");
|
|
}
|
|
}
|
|
|
|
# set the test config file: either the corresponding X.cfg, or fhem.cfg
|
|
sub
|
|
prepareFhemTestFile()
|
|
{
|
|
return if($ARGV[0] && $ARGV[0] ne "-t" || @ARGV < 2);
|
|
shift @ARGV;
|
|
|
|
if($ARGV[0] !~ m,^(.*?)([^/]+)\.t$, || !-r $ARGV[0]) {
|
|
print STDERR "Need a .t file as argument for -t\n";
|
|
exit(1);
|
|
}
|
|
my ($dir, $fileBase) = ($1, $2);
|
|
|
|
$fhemTestFile = $ARGV[0];
|
|
$ARGV[0] = "${dir}fhem.cfg" if(-r "${dir}fhem.cfg");
|
|
$ARGV[0] = "$dir$fileBase.cfg" if(-r "$dir$fileBase.cfg");
|
|
}
|
|
|
|
sub
|
|
execFhemTestFile()
|
|
{
|
|
return if(!$fhemTestFile);
|
|
$attr{global}{autosave} = 0;
|
|
AnalyzeCommand(undef, "define .ftu FhemTestUtils")
|
|
if(!grep { $defs{$_}{TYPE} eq "FhemTestUtils" } keys %defs);
|
|
InternalTimer(1, sub { require $fhemTestFile }, 0 ) if($fhemTestFile);
|
|
}
|
|
|
|
# return undef if ok or error. Prameter: regexp, error context
|
|
sub
|
|
CheckRegexp($$)
|
|
{
|
|
my ($re,$context) = @_;
|
|
return "Empty regexp in $context" if(!defined($re));
|
|
return "Bad regexp >$re< in $context" if($re =~ m/^[*+]/);
|
|
|
|
my $warn;
|
|
my $osig = $SIG{__WARN__};
|
|
$SIG{__WARN__} = sub { $warn = $_[0]};
|
|
eval { "Hallo" =~ m/^$re$/ };
|
|
$SIG{__WARN__} = $osig;
|
|
|
|
return "Bad regexp >$re< in $context: $@" if($@);
|
|
return "Bad regexp >$re< in $context: $warn" if($warn);
|
|
return undef;
|
|
}
|
|
|
|
1;
|