FHEM/fhem-mirror
2
0
Fork 0
mirror of https://github.com/fhem/fhem-mirror.git synced 2025-01-31 06:39:11 +00:00
Code Issues Releases Wiki Activity
a425dda9bd
fhem-mirror/fhem/fhem.pl
rudolfkoenig e416ae53af - showtime added for pgm2 (useful for FS20 piri display) 
- defattr command added, it makes easier to assign room, type, etc for a group
    of devices.
  - em1010.pl added to the contrib directory. It seems that we are able
    to read out the EM1010PC. Not verified with multiple devices.


git-svn-id: https://svn.fhem.de/fhem/trunk@11 2b470e98-0d58-463d-a4d8-8e2adae1ed80
2007-02-11 17:58:23 +00:00

1687 lines
38 KiB
Prolog
Executable File
Raw Blame History

#!/usr/bin/perl
my $version = "=VERS= from =DATE=";
################################################################
#
# Copyright notice
#
# (c) 2005 Copyright: Rudolf Koenig (r dot koenig at koeniglich dot de)
# All rights reserved
#
# This script free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# The GNU General Public License can be found at
# http://www.gnu.org/copyleft/gpl.html.
# A copy is found in the textfile GPL.txt and important notices to the license
# from the author is found in LICENSE.txt distributed with these scripts.
#
# This script is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# This copyright notice MUST APPEAR in all copies of the script!
# Thanks for Tosti's site (<http://www.tosti.com/FHZ1000PC.html>)
# for inspiration.
#
# Homepage: http://www.koeniglich.de/fhem/fhem.html
use strict;
use warnings;
use IO::File;
use IO::Socket;
use Net::hostent;
use Time::HiRes qw(gettimeofday);
##################################################
# Forward declarations
#
sub AnalyzeInput($);
sub AnalyzeCommand($$);
sub AnalyzeCommandChain($$);
sub IOWrite($@);
sub AssignIoPort($);
sub InternalTimer($$$);
sub fhz($);
sub CommandChain($$);
sub DoClose($);
sub HandleTimeout();
sub Log($$);
sub OpenLogfile($);
sub ResolveDateWildcards($@);
sub SignalHandling();
sub TimeNow();
sub DoSavefile();
sub SemicolonEscape($);
sub XmlEscape($);
sub CommandAt($$);
sub CommandAttr($$);
sub CommandDefAttr($$);
sub CommandDefine($$);
sub CommandDelete($$);
sub CommandFhzDev($$);
sub CommandGet($$);
sub CommandHelp($$);
sub CommandInclude($$);
sub CommandInform($$);
sub CommandList($$);
sub CommandLogfile($$);
sub CommandModpath($$);
sub CommandNotifyon($$);
sub CommandPidfile($$);
sub CommandPort($$);
sub CommandRereadCfg($$);
sub CommandQuit($$);
sub CommandSavefile($$);
sub CommandSet($$);
sub CommandSetstate($$);
sub CommandSleep($$);
sub CommandShutdown($$);
sub CommandVerbose($$);
sub CommandXmlList($$);
sub CommandTrigger($$);
##################################################
# Variables:
# global, to be able to access them from modules
use vars qw(%defs); # FHEM device/button definitions
use vars qw(%logs); # Log channels
use vars qw(%attr); # Attributes
use vars qw(%value); # Current values, see commandref.html
use vars qw(%oldvalue); # Old values, see commandref.html
use vars qw(%devmods); # List of loaded device modules
my %ntfy;
my %at;
my $server; # Server socket
my $verbose = 0;
my $logfile; # logfile name, if its "-" then wont background
my $currlogfile; # logfile, without wildcards
my $logopened;
my %client; # Client array
my %logmods; # List of loaded logger modules
my $savefile = ""; # Save ste info and at cmd's here
my $nextat;
my $rcvdquit; # Used for quit handling in init files
my $configfile=$ARGV[0];
my $sig_term = 0; # if set to 1, terminate (saving the state)
my $modpath_set; # Check if modpath was used, and report if not.
my $global_cl; # To use from perl snippets
my $devcount = 0; # To sort the devices
my %defattr; # Default attributes
my %intAt; # Internal at timer hash.
my $intAtCnt=0;
my $init_done = 0;
my $pidfilename;
my %cmds = (
"?" => { Fn=>"CommandHelp",
Hlp=>",get this help" },
"at" => { Fn=>"CommandAt",
Hlp=>"<timespec> <command>,issue a command at a given time" },
"attr" => { Fn=>"CommandAttr",
Hlp=>"<devname> <attrname> <attrvalue>,set attributes for <devname>" },
"defattr" => { Fn=>"CommandDefAttr",
Hlp=>"<attrname> <attrvalue>,set attr for following definitions" },
"define" => { Fn=>"CommandDefine",
Hlp=>"<name> <type> <options>,define a code" },
"delete" => { Fn=>"CommandDelete",
Hlp=>"{def|ntfy|at} name,delete the corresponding definition"},
"get" => { Fn=>"CommandGet",
Hlp=>"<name> <type dependent>,request data from <name>" },
"help" => { Fn=>"CommandHelp",
Hlp=>",get this help" },
"include" => { Fn=>"CommandInclude",
Hlp=>"<filename>,read the commands from <filenname>" },
"inform" => { Fn=>"CommandInform",
Hlp=>"{on|off},echo all commands and events to this client" },
"list" => { Fn=>"CommandList",
Hlp=>"[device],list definitions and status info" },
"logfile" => { Fn=>"CommandLogfile",
Hlp=>"filename,use - for stdout" },
"modpath" => { Fn=>"CommandModpath",
Hlp=>"<path>,the directory where the FHEM subdir is" },
"notifyon"=> { Fn=>"CommandNotifyon",
Hlp=>"<name> <shellcmd>,exec <shellcmd> when recvd signal for <name>" },
"pidfile" => { Fn=>"CommandPidfile",
Hlp=>"filename,write the process id into the pidfile" },
"port" => { Fn=>"CommandPort",
Hlp=>"<port> [global],TCP/IP port for the server" },
"quit" => { Fn=>"CommandQuit",
Hlp=>",end the client session" },
"reload" => { Fn=>"CommandReload",
Hlp=>"<module-name>,reload the given module (e.g. 99_PRIV)" },
"rereadcfg" => { Fn=>"CommandRereadCfg",
Hlp=>",reread the config file" },
"savefile"=> { Fn=>"CommandSavefile",
Hlp=>"<filename>,on shutdown save all states and at entries" },
"set" => { Fn=>"CommandSet",
Hlp=>"<name> <type dependent>,transmit code for <name>" },
"setstate"=> { Fn=>"CommandSetstate",
Hlp=>"<name> <state>,set the state shown in the command list" },
"shutdown"=> { Fn=>"CommandShutdown",
Hlp=>",terminate the server" },
"sleep" => { Fn=>"CommandSleep",
Hlp=>"<usecs>,sleep for usecs" },
"trigger" => { Fn=>"CommandTrigger",
Hlp=>"<dev> <state>,trigger notify command" },
"verbose" => { Fn=>"CommandVerbose",
Hlp=>"<level>,verbosity level, 0-5" },
"xmllist" => { Fn=>"CommandXmlList",
Hlp=>",list definitions and status info as xml" },
);
###################################################
# Start the program
if(int(@ARGV) != 1 && int(@ARGV) != 2) {
print "Usage:\n";
print "as server: fhem configfile\n";
print "as client: fhem [host:]port cmd\n";
CommandHelp(undef, undef);
exit(1);
}
###################################################
# Client code
if(int(@ARGV) == 2) {
my $buf;
my $addr = $ARGV[0];
$addr = "localhost:$addr" if($ARGV[0] !~ m/:/);
$server = IO::Socket::INET->new(PeerAddr => $addr);
die "Can't connect to $addr\n" if(!$server);
syswrite($server, "$ARGV[1] ; quit\n");
my $err = 0;
while(sysread($server, $buf, 256) > 0) {
print($buf);
$err = 1;
}
exit($err);
}
my $ret = CommandInclude(undef, $configfile);
die($ret) if($ret);
if($logfile ne "-") {
defined(my $pid = fork) || die "Can't fork: $!";
exit(0) if $pid;
}
die("No modpath specified in the configfile.\n") if(!$modpath_set);
if($savefile && -r $savefile) {
$ret = CommandInclude(undef, $savefile);
die($ret) if($ret);
}
SignalHandling();
Log 0, "Server started (version $version, pid $$)";
################################################
# Main loop
$init_done = 1;
CommandPidfile(undef, $pidfilename) if($pidfilename);
while (1) {
my ($rout, $rin) = ('', '');
vec($rin, $server->fileno(), 1) = 1;
foreach my $p (keys %defs) {
vec($rin, $defs{$p}{FD}, 1) = 1 if($defs{$p}{FD});
}
foreach my $c (keys %client) {
vec($rin, fileno($client{$c}{fd}), 1) = 1;
}
my $nfound = select($rout=$rin, undef, undef, HandleTimeout());
CommandShutdown(undef, undef) if($sig_term);
if($nfound < 0) {
next if ($! == EAGAIN() || $! == EINTR() || $! == 0);
die("Select error $nfound / $!\n");
}
###############################
# Message from the hardware (FHZ1000/WS3000/etc)
foreach my $p (keys %defs) {
next if(!$defs{$p}{FD} || !vec($rout, $defs{$p}{FD}, 1));
no strict "refs";
&{$devmods{$defs{$p}{TYPE}}{ReadFn}}($defs{$p});
use strict "refs";
}
if(vec($rout, $server->fileno(), 1)) {
my @clientinfo = $server->accept();
if(!@clientinfo) {
Print("ERROR", 1, "016 Accept failed for admin port");
next;
}
my @clientsock = sockaddr_in($clientinfo[1]);
my $fd = $clientinfo[0];
$client{$fd}{fd} = $fd;
$client{$fd}{addr} = inet_ntoa($clientsock[1]) . ":" . $clientsock[0];
$client{$fd}{buffer} = "";
Log 4, "Connection accepted from $client{$fd}{addr}";
}
foreach my $c (keys %client) {
next unless (vec($rout, fileno($client{$c}{fd}), 1));
my $buf;
my $ret = sysread($client{$c}{fd}, $buf, 256);
if(!defined($ret) || $ret <= 0) {
DoClose($c);
next;
}
if(ord($buf) == 4) { # EOT / ^D
CommandQuit($c, "");
next;
}
$buf =~ s/\r//g;
$client{$c}{buffer} .= $buf;
AnalyzeInput($c);
}
}
################################################
sub
IsDummy($)
{
my $dev = shift;
return 1 if(defined($attr{$dev}) && defined($attr{$dev}{dummy}));
return 0;
}
################################################
sub
GetLogLevel($)
{
my $dev = shift;
return $attr{$dev}{loglevel}
if(defined($attr{$dev}) && defined($attr{$dev}{loglevel}));
return 2;
}
################################################
sub
Log($$)
{
my ($loglevel, $text) = @_;
return if($loglevel > $verbose);
my @t = localtime;
my $nfile = ResolveDateWildcards($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]);
# my ($seconds, $microseconds) = gettimeofday();
# $tim = sprintf("%04d.%02d.%02d %02d:%02d:%02d.%03d",
# $t[5]+1900,$t[4]+1,$t[3], $t[2],$t[1],$t[0], $microseconds/1000);
if($logopened) {
print LOG "$tim $loglevel: $text\n";
} else {
print "$tim $loglevel: $text\n";
}
return undef;
}
#####################################
sub
DoClose($)
{
my $c = shift;
Log 4, "Connection closed for $client{$c}{addr}";
close($client{$c}{fd});
delete($client{$c});
return undef;
}
#####################################
sub
IOWrite($@)
{
my ($hash, @a) = @_;
my $iohash = $hash->{IODev};
if(!$iohash) {
Log 5, "No IO device found for $hash->{NAME}";
return;
}
no strict "refs";
&{$devmods{$iohash->{TYPE}}{WriteFn}}($iohash, @a);
use strict "refs";
}
#####################################
sub
AnalyzeInput($)
{
my $c = shift;
while($client{$c}{buffer} =~ m/\n/) {
my ($cmd, $rest) = split("\n", $client{$c}{buffer}, 2);
$client{$c}{buffer} = $rest;
if($cmd) {
AnalyzeCommandChain($c, $cmd);
return if(!defined($client{$c})); # quit
} else {
$client{$c}{prompt} = 1;
}
syswrite($client{$c}{fd}, "FHZ> ")
if($client{$c}{prompt} && $rest !~ m/\n/);
}
}
#####################################
sub
AnalyzeCommandChain($$)
{
my ($c, $cmd) = @_;
$cmd =~ s/#.*$//;
$cmd =~ s/;;/____/g;
foreach my $subcmd (split(";", $cmd)) {
$subcmd =~ s/____/;/g;
AnalyzeCommand($c, $subcmd);
last if($c && !defined($client{$c})); # quit
}
}
#####################################
# Used from perl oneliners inside of scripts
sub
fhz($)
{
my $param = shift;
return AnalyzeCommandChain($global_cl, $param);
}
#####################################
sub
AnalyzeCommand($$)
{
my ($cl, $cmd) = @_;
$cmd =~ s/^[ \t]*//; # Strip space
$cmd =~ s/[ \t]*$//;
Log 5, "Cmd: >$cmd<";
return if(!$cmd);
if($cmd =~ m/^{.*}$/) { # Perl code
# Make life easier for oneliners:
%value = ();
foreach my $d (keys %defs) { $value{$d} = $defs{$d}{STATE } }
my ($sec,$min,$hour,$mday,$month,$year,$wday,$yday,$isdst) = localtime;
my $we = (($wday==0 || $wday==6) ? 1 : 0);
$month++;
$year+=1900;
$global_cl = $cl;
my $ret = eval $cmd;
$ret = $@ if($@);
if($ret) {
if($cl) {
syswrite($client{$cl}{fd}, "$ret\n")
} else {
Log 3, $ret;
}
}
return $ret;
}
if($cmd =~ m/^"(.*)"$/) { # Shell code, always in bg
system("$1 &");
return;
}
$cmd =~ s/^[ \t]*//;
my ($fn, $param) = split("[ \t][ \t]*", $cmd, 2);
return if(!$fn);
#############
# Search for abbreviation
if(!defined($cmds{$fn})) {
foreach my $f (sort keys %cmds) {
if(length($f) > length($fn) && substr($f, 0, length($fn)) eq $fn) {
Log 5, "$fn => $f";
$fn = $f;
last;
}
}
}
if(!defined($cmds{$fn})) {
if($cl) {
syswrite($client{$cl}{fd}, "Unknown command $fn, try help\n");
} else {
Log 1, "Unknown command >$fn<, try help";
}
return;
}
$param = "" if(!defined($param));
no strict "refs";
my $ret = &{$cmds{$fn}{Fn} }($cl, $param);
use strict "refs";
if($ret) {
if($cl) {
syswrite($client{$cl}{fd}, $ret . "\n");
} else {
Log 1, $ret;
return $ret;
}
}
}
#####################################
sub
CommandHelp($$)
{
my ($cl, $param) = @_;
my $str = "\n" .
"Possible commands:\n\n" .
"Command Parameter Description\n" .
"-----------------------------------------------\n";
for my $cmd (sort keys %cmds) {
my @a = split(",", $cmds{$cmd}{Hlp}, 2);
$str .= sprintf("%-9s %-25s %s\n", $cmd, $a[0], $a[1]);
}
return $str;
}
sub
CommandInclude($$)
{
my ($cl, $arg) = @_;
if(!open(CFG, $arg)) {
return "Can't open $arg: $!";
}
my $bigcmd = "";
$rcvdquit = 0;
while(my $l = <CFG>) {
chomp($l);
if($l =~ m/^(.*)\\$/) { # Multiline commands
$bigcmd .= $1;
} else {
AnalyzeCommandChain($cl, $bigcmd . $l);
$bigcmd = "";
}
last if($rcvdquit);
}
close(CFG);
return undef;
}
#####################################
sub
CommandPort($$)
{
my ($cl, $arg) = @_;
my ($port, $global) = split(" ", $arg);
if($global && $global ne "global") {
return "Bad syntax, usage: port <portnumber> [global]";
}
close($server) if($server);
$server = IO::Socket::INET->new(
Proto => 'tcp',
LocalHost => ($global ? undef : "localhost"),
LocalPort => $port,
Listen => 10,
ReuseAddr => 1);
die "Can't open server port at $port\n" if(!$server);
return undef;
}
#####################################
sub
OpenLogfile($)
{
my $param = shift;
close(LOG) if($logfile);
$logopened=0;
$currlogfile = $param;
if($currlogfile eq "-") {
open LOG, '>&STDOUT' or die "Can't dup stdout: $!";
} else {
open(LOG, ">>$currlogfile") || return("Can't open $currlogfile: $!");
# Redirect stdin/stderr
open STDIN, '</dev/null' or return "Can't read /dev/null: $!";
close(STDERR);
open(STDERR, ">>$currlogfile") or return "Can't append STDERR to log: $!";
STDERR->autoflush(1);
close(STDOUT);
open STDOUT, '>&STDERR' or return "Can't dup stdout: $!";
STDOUT->autoflush(1);
}
LOG->autoflush(1);
$logopened = 1;
return undef;
}
#####################################
sub
CommandLogfile($$)
{
my ($cl, $param) = @_;
$logfile = $param;
my @t = localtime;
my $ret = OpenLogfile(ResolveDateWildcards($param, @t));
die($ret) if($ret);
return undef;
}
#####################################
sub
CommandVerbose($$)
{
my ($cl, $param) = @_;
if($param =~ m/^[0-5]$/) {
$verbose = $param;
return undef;
} else {
return "Valid value for verbose are 0,1,2,3,4,5";
}
}
#####################################
sub
CommandRereadCfg($$)
{
my ($cl, $param) = @_;
return "RereadCfg: No parameters are accepted" if($param);
DoSavefile();
foreach my $d (keys %defs) {
no strict "refs";
my $ret = &{$devmods{$defs{$d}{TYPE}}{UndefFn}}($defs{$d}, $d);
use strict "refs";
return $ret if($ret);
}
%defs = ();
%logs = ();
%attr = ();
%ntfy = ();
%at = ();
my $ret;
$ret = CommandInclude($cl, $configfile);
return $ret if($ret);
$ret = CommandInclude($cl, $savefile) if($savefile);
return $ret;
}
#####################################
sub
CommandQuit($$)
{
my ($cl, $param) = @_;
if(!$cl) {
$rcvdquit = 1;
return;
}
syswrite($client{$cl}{fd}, "Bye...\n") if($client{$cl}{prompt});
DoClose($cl);
return undef;
}
#####################################
sub
DoSavefile()
{
return if(!$savefile);
if(!open(SFH, ">$savefile")) {
Log 1, "Cannot open $savefile: $!";
return;
}
my $t = localtime;
print SFH "#$t\n";
foreach my $d (sort keys %defs) {
my $t = $defs{$d}{TYPE};
print SFH "setstate $d $defs{$d}{STATE}\n"
if($defs{$d}{STATE} && $defs{$d}{STATE} ne "unknown");
#############
# Now the detailed list
no strict "refs";
my $str = &{$devmods{$defs{$d}{TYPE}}{ListFn}}($defs{$d});
use strict "refs";
next if($str =~ m/^No information about/);
foreach my $l (split("\n", $str)) {
print SFH "setstate $d $l\n"
}
}
foreach my $t (sort keys %at) {
# $t =~ s/_/ /g; # Why is this here?
print SFH "at $t\n";
}
close(SFH);
}
#####################################
sub
CommandShutdown($$)
{
my ($cl, $param) = @_;
Log 0, "Server shutdown";
DoSavefile();
unlink($pidfilename) if($pidfilename);
exit(0);
}
#####################################
sub
CommandNotifyon($$)
{
my ($cl, $param) = @_;
my @a = split("[ \t]", $param, 2);
# Checking for misleading regexps
eval { "Hallo" =~ m/^$a[0]$/ };
return "Bad regexp: $@" if($@);
$ntfy{$a[0]} = SemicolonEscape($a[1]);
return undef;
}
#####################################
sub
DoSet(@)
{
my @a = @_;
my $dev = $a[0];
my $ret;
no strict "refs";
$ret = &{$devmods{$defs{$dev}{TYPE}}{SetFn}}($defs{$dev}, @a);
use strict "refs";
return $ret if($ret);
shift @a;
return DoTrigger($dev, join(" ", @a));
}
#####################################
sub
CommandSet($$)
{
my ($cl, $param) = @_;
my @a = split("[ \t][ \t]*", $param);
return "Usage: set <name> <type-dependent-options>" if(int(@a) < 1);
my $dev = $a[0];
my @rets;
if(defined($defs{$dev})) {
return DoSet(@a);
} elsif($dev =~ m/,/) { # Enumeration (separated by ,)
foreach my $sdev (split(",", $dev)) {
push @rets, "Please define $sdev first" if(!defined($defs{$sdev}));
$a[0] = $sdev;
my $ret = DoSet(@a);
push @rets, $ret if($ret);
}
return join("\n", @rets);
} elsif($dev =~ m/-/) { # Range (separated by -)
my @lim = split("-", $dev);
foreach my $sdev (keys %defs) {
next if($sdev lt $lim[0] || $sdev gt $lim[1]);
$a[0] = $sdev;
my $ret = DoSet(@a);
push @rets, $ret if($ret);
}
return join("\n", @rets);
} else {
return "Please define $dev first ($param)";
}
}
#####################################
sub
CommandGet($$)
{
my ($cl, $param) = @_;
my @a = split("[ \t][ \t]*", $param);
return "Usage: get <name> <type-dependent-options>" if(int(@a) < 1);
my $dev = $a[0];
return "Please define $dev first ($param)" if(!defined($defs{$dev}));
########################
# Type specific set
my $ret;
no strict "refs";
$ret = &{$devmods{$defs{$a[0]}{TYPE}}{GetFn}}($defs{$dev}, @a);
use strict "refs";
return $ret;
}
#####################################
sub
GetTimeSpec($)
{
my ($tspec) = @_;
my ($hr, $min, $sec, $fn);
if($tspec =~ m/^([0-9]+):([0-5][0-9]):([0-5][0-9])$/) {
($hr, $min, $sec) = ($1, $2, $3);
} elsif($tspec =~ m/^([0-9]+):([0-5][0-9])$/) {
($hr, $min, $sec) = ($1, $2, 0);
} elsif($tspec =~ m/^{(.*)}$/) {
$fn = $1;
$tspec = eval $fn;
if(!$@ && $tspec =~ m/^([0-9]+):([0-5][0-9]):([0-5][0-9])$/) {
($hr, $min, $sec) = ($1, $2, $3);
} elsif(!$@ && $tspec =~ m/^([0-9]+):([0-5][0-9])$/) {
($hr, $min, $sec) = ($1, $2, 0);
} else {
$tspec = "<empty string>" if(!$tspec);
return ("the at function must return a timespec HH:MM:SS and not $tspec.",
undef, undef, undef, undef);
}
} else {
return ("Wrong timespec $tspec: either HH:MM:SS or {perlcode}",
undef, undef, undef, undef);
}
return (undef, $hr, $min, $sec, $fn);
}
#####################################
sub
CommandAt($$)
{
my ($cl, $def) = @_;
my ($tm, $command) = split("[ \t]+", $def, 2);
return "Usage: at <timespec> <fhem-command>" if(!$command);
return "Wrong timespec, use \"[+][*[{count}]]<time or func>\""
if($tm !~ m/^(\+)?(\*({\d+})?)?(.*)$/);
my ($rel, $rep, $cnt, $tspec) = ($1, $2, $3, $4);
my ($err, $hr, $min, $sec, $fn) = GetTimeSpec($tspec);
return $err if($err);
$rel = "" if(!defined($rel));
$rep = "" if(!defined($rep));
$cnt = "" if(!defined($cnt));
my $ot = time;
my @lt = localtime($ot);
my $nt = $ot;
$nt -= ($lt[2]*3600+$lt[1]*60+$lt[0]) # Midnight for absolute time
if($rel ne "+");
$nt += ($hr*3600+$min*60+$sec); # Plus relative time
$nt += 86400 if($ot >= $nt);# Do it tomorrow...
@lt = localtime($nt);
my $ntm = sprintf("%02d:%02d:%02d", $lt[2], $lt[1], $lt[0]);
if($rep) { # Setting the number of repetitions
$cnt =~ s/[{}]//g;
return undef if($cnt eq "0");
$cnt = 0 if(!$cnt);
$cnt--;
$at{$def}{REP} = $cnt;
}
$at{$def}{NTM} = $ntm if($rel eq "+" || $fn);
$at{$def}{TIM} = $nt;
$at{$def}{CMD} = SemicolonEscape($command);
$nextat = $nt if(!$nextat || $nextat > $nt);
return undef;
}
#####################################
sub
CommandDefine($$)
{
my ($cl, $def) = @_;
my @a = split("[ \t][ \t]*", $def);
return "Usage: define <name> <type> <type dependent arguments>"
if(int(@a) < 2);
return "Unknown type $a[1]"
if(!defined($devmods{$a[1]}) && !defined($logmods{$a[1]}));
return "$a[0] already defined" if(defined($defs{$a[0]}));
return "Only following characters are allowed in a name: A-Za-z0-9-.:"
if($a[0] !~ m/^[a-z0-9.:-]*$/i);
my %hash;
$hash{NAME} = $a[0];
$hash{TYPE} = $a[1];
$hash{STATE} = "???";
$hash{DEF} = $def;
$hash{NR} = $devcount++;
# If the device wants to issue initialization gets/sets, then it should be
# in the global hash.
my $ghash = (defined($devmods{$a[1]}) ? \%defs : \%logs);
$ghash->{$a[0]} = \%hash;
########################
# Type specific define
my $ret;
my $fnname = ($devmods{$a[1]} ? $devmods{$a[1]}{DefFn} :
$logmods{$a[1]}{DefFn} );
no strict "refs";
$ret = &{$fnname}(\%hash, @a);
use strict "refs";
if($ret) {
delete $ghash->{$a[0]}
} else {
foreach my $da (sort keys (%defattr)) { # Default attributes
CommandAttr($cl, "$a[0] $da $defattr{$da}");
}
}
return $ret;
}
#############
# internal
sub
AssignIoPort($)
{
my ($hash) = @_;
# Set the I/O device
for my $p (sort { $defs{$b}{NR} cmp $defs{$a}{NR} } keys %defs) {
my $cl = $devmods{$defs{$p}{TYPE}}{Clients};
if(defined($cl) && $cl =~ m/:$hash->{TYPE}:/) {
$hash->{IODev} = $defs{$p};
last;
}
}
Log 3, "No I/O device found for $hash->{NAME}" if(!$hash->{IODev});
}
#############
# internal
sub
DoDel($$$)
{
my($hash, $type, $v) = @_;
if($type eq "def") {
no strict "refs";
my $ret = &{$devmods{$hash->{$v}{TYPE}}{UndefFn}}($hash->{$v}, $v);
use strict "refs";
return $ret if($ret);
delete($attr{$v});
}
delete($hash->{$v});
return undef;
}
#############
sub
CommandDelete($$)
{
my ($cl, $def) = @_;
my @a = split("[ \t]+", $def, 2);
my $hash;
my $arg = $a[1];
if($a[0] eq "def") {
$hash = \%defs;
} elsif($a[0] eq "ntfy") {
$hash = \%ntfy;
} elsif($a[0] eq "at") {
$hash = \%at;
$arg =~ s/ \([0-2][0-9]:[0-5][0-9]:[0-5][0-9]\)$//;
} elsif($a[0] eq "attr") {
$hash = \%attr;
} else {
return "Unknown delete category, use one of def, ntfy or at";
}
my $found;
if(defined($hash->{$arg})) {
my $ret = DoDel($hash, $a[0], $arg);
return $ret if($ret);
$found = 1;
} else {
# Checking for misleading regexps
eval { "Hallo" =~ m/$arg/ };
return "Bad argument: $@" if($@);
foreach my $v (keys %{ $hash }) {
if($v =~ m/$arg/) {
my $ret = DoDel($hash, $a[0], $v);
return $ret if($ret);
$found = 1;
}
}
##############
# Handle the logs too
if(!$found && $a[0] eq "def") {
foreach my $v (keys %logs) {
if($v =~ m/$arg/) {
no strict "refs";
my $ret = &{$logmods{$logs{$v}{TYPE}}{UndefFn}}($logs{$v}, $v);
use strict "refs";
return $ret if($ret);
delete($logs{$v});
$found = 1;
}
}
}
}
return "No $a[0] values matched $a[1]" if(!$found);
return undef;
}
#####################################
sub
CommandList($$)
{
my ($cl, $param) = @_;
my $str;
if(!$param) {
$str = "\nType list <name> for detailed info.\n";
my $lt = "";
# Sort first by type then by name
for my $d (sort { my $x = $devmods{$defs{$a}{TYPE}}{ORDER} cmp
$devmods{$defs{$b}{TYPE}}{ORDER};
$x = ($a cmp $b) if($x == 0); $x; } keys %defs) {
my $t = $defs{$d}{TYPE};
$str .= "\n$t devices:\n" if($t ne $lt);
$str .= sprintf(" %-20s (%s)\n", $d, $defs{$d}{STATE});
$lt = $t;
}
$str .= "\n";
$str .= "NotifyOn:\n";
for my $n (sort keys %ntfy) {
$str .= sprintf(" %-20s %s\n", $n, $ntfy{$n});
}
$str .= "\n";
$str .= "At:\n";
for my $i (sort keys %at) {
if($at{$i}{NTM}) {
$str .= " $i ($at{$i}{NTM})\n";
} else {
$str .= " $i\n";
}
}
$str .= "\n";
$str .= "Logs:\n";
for my $i (sort keys %logs) {
$str .= " " . $logs{$i}{DEF} . "\n";
}
} else {
my @a = split(" ", $param);
return "Usage: list [name]" if(@a > 1);
return "No device named $a[0] found" if(!defined($defs{$a[0]}));
no strict "refs";
$str = "\n";
$str .= "Definition: $defs{$a[0]}{DEF}\n";
$str .= "Attached I/O device: $defs{$a[0]}{IODev}{NAME}\n"
if($defs{$a[0]}{IODev});
foreach my $c (sort keys %{$attr{$a[0]}}) {
$str .= "$c $attr{$a[0]}{$c}\n";
}
$str .= &{$devmods{$defs{$a[0]}{TYPE}}{ListFn}}($defs{$a[0]});
use strict "refs";
}
return $str;
}
#####################################
sub
XmlEscape($)
{
my $a = shift;
$a =~ s/&/&amp;/g;
$a =~ s/"/&quot;/g;
$a =~ s/</&lt;/g;
$a =~ s/>/&gt;/g;
$a =~ s/<2F>/&#b0;/g;
return $a;
}
#####################################
sub
CommandXmlList($$)
{
my ($cl, $param) = @_;
my $str = "<FHZINFO>\n";
my $lt = "";
for my $d (sort { my $x =
$devmods{$defs{$a}{TYPE}}{ORDER} cmp
$devmods{$defs{$b}{TYPE}}{ORDER};
$x = ($a cmp $b) if($x == 0); $x; } keys %defs) {
my $t = $defs{$d}{TYPE};
if($t ne $lt) {
$str .= "\t</${lt}_DEVICES>\n" if($lt);
$str .= "\t<${t}_DEVICES>\n";
}
$lt = $t;
no strict "refs";
my @lines = split("\n", &{$devmods{$t}{ListFn}}($defs{$d}));
use strict "refs";
my $def = XmlEscape($defs{$d}{DEF});
my $xmld = XmlEscape($d);
my $xmls = XmlEscape($defs{$d}{STATE});
$def =~ s/ +/ /g;
$str .= "\t\t<$t name=\"$xmld\" definition=\"$def\" state=\"$xmls\"";
my $multiline = (int(@lines) || defined($attr{$d}));
$str .= ($multiline ? ">\n" : "/>\n");
foreach my $c (sort keys %{$attr{$d}}) {
my $xc = XmlEscape($c);
my $xv = XmlEscape($attr{$d}{$c});
$str .= "\t\t\t<ATTR key=\"$xc\" value=\"$xv\"/>\n";
}
foreach my $l (@lines) {
my ($date, $time, $attr, $val) = split(" ", $l, 4);
$val = "" if(!$val);
$attr = XmlEscape($attr);
$val = XmlEscape($val);
$str .= "\t\t\t<STATE name=\"$attr\" " .
"value=\"$val\" measured=\"$date $time\"/>\n";
}
$str .= "\t\t</$t>\n" if($multiline);
}
$str .= "\t</${lt}_DEVICES>\n" if($lt);
$lt = "";
for my $i (sort keys %logs) {
$str .= "\t<LOGS>\n" if(!$lt);
$lt = XmlEscape($logs{$i}{DEF});
my @a = split(" ", $lt, 2);
$str .= "\t\t<LOG name=\"$a[0]\" definition=\"$lt\"/>\n";
foreach my $a (sort keys %{$attr{$i}}) {
my $xa = XmlEscape($a);
my $v = XmlEscape($attr{$i}{$a});
$str .= "\t\t\t<ATTR key=\"$xa\" value=\"$v\"/>\n";
}
}
$str .= "\t</LOGS>\n" if($lt);
$str .= "\t<NOTIFICATIONS>\n";
for my $n (sort keys %ntfy) {
my $xn = XmlEscape($n);
my $cmd = XmlEscape($ntfy{$n});
$str .= "\t\t<NOTIFY_ON event=\"$xn\" command=\"$cmd\"/>\n";
}
$str .= "\t</NOTIFICATIONS>\n";
$str .= "\t<AT_JOBS>\n";
for my $i (sort keys %at) {
my $cmd = XmlEscape($i);
if($at{$i}{NTM}) {
$str .= "\t\t<AT command=\"$cmd\" next=\"$at{$i}{NTM}\"/>\n";
} else {
$str .= "\t\t<AT command=\"$cmd\"/>\n";
}
foreach my $c (sort keys %{$attr{$i}}) {
my $xc = XmlEscape($c);
my $v = XmlEscape($attr{$i}{$c});
$str .= "\t\t\t<ATTR key=\"$xc\" value=\"$v\"/>\n";
}
}
$str .= "\t</AT_JOBS>\n";
$str .= "</FHZINFO>\n";
return $str;
}
#####################################
sub
CommandReload($$)
{
my ($cl, $param) = @_;
my %hash;
$param =~ s,[\./],,g;
$param =~ s,\.pm$,,g;
my $file = "$modpath_set/FHEM/$param.pm";
return "Can't read $file: $!" if(! -r "$file");
my $m = $param;
$m =~ s,^[0-9][0-9]_,,;
Log 2, "Loading $file";
my $ret;
no strict "refs";
eval {
do "$file";
$ret = &{ "${m}_Initialize" }(\%hash);
};
if($@) {
return "$@";
}
use strict "refs";
$devmods{$m} = \%hash if($hash{Category} eq "DEV");
$logmods{$m} = \%hash if($hash{Category} eq "LOG");
return undef;
}
#####################################
sub
CommandModpath($$)
{
my ($cl, $param) = @_;
return "modpath must point to a directory where the FHEM subdir is"
if(! -d "$param/FHEM");
my $modpath = "$param/FHEM";
opendir(DH, $modpath) || return "Can't read $modpath: $!";
my $counter = 0;
foreach my $m (sort grep(/^[0-9][0-9].*\.pm$/,readdir(DH))) {
$counter++;
Log 5, "Loading $m";
require "$modpath/$m";
next if($m !~ m/([0-9][0-9])_(.*)\.pm$/);
$m = $2;
my %hash;
$hash{ORDER} = $1;
no strict "refs";
my $ret = &{ "${m}_Initialize" }(\%hash);
use strict "refs";
$devmods{$m} = \%hash if($hash{Category} eq "DEV");
$logmods{$m} = \%hash if($hash{Category} eq "LOG");
}
closedir(DH);
if(!$counter) {
return "No modules found, " .
"point modpath to a directory where the FHEM subdir is";
}
$modpath_set = $param;
return undef;
}
#####################################
sub
CommandAttr($$)
{
my ($cl, $param) = @_;
my $ret = undef;
my @a = split(" ", $param, 3);
return "Usage: attr [<devname>|at] <attrname> [<attrvalue>]" if(@a < 2);
return "Usage: attr at <at-spec> <attrname>" if(@a < 3 && $a[0] eq "at");
my $have = 0;
if($a[0] eq "at") { # "at" special
my $arg = $a[1];
$arg =~ s/ \([0-2][0-9]:[0-5][0-9]:[0-5][0-9]\)$//;
if(defined($at{$arg})) { # First the exact version
$attr{$arg}{$a[2]} = "1";
} else { # then the regexp
# Checking for misleading regexps
eval { "Hallo" =~ m/$arg/ };
return "Bad argument: $@" if($@);
foreach my $a (keys %at) {
if($a =~ m/$arg/) {
$attr{$a}{$a[2]} = "1";
$have = 1;
last;
}
}
}
return "No at spec found" if(!$have);
return undef;
}
$have = 1 if(defined($defs{$a[0]}));
$have = 1 if(defined($logs{$a[0]}));
return "Please define $a[0] first: no device or log definition found"
if(!$have);
if(defined($a[2])) {
$attr{$a[0]}{$a[1]} = $a[2];
} else {
$attr{$a[0]}{$a[1]} = "1";
}
return undef;
}
sub
CommandDefAttr($$)
{
my ($cl, $param) = @_;
my @a = split(" ", $param, 2);
if(int(@a) == 0) {
%defattr = ();
} elsif(int(@a) == 1) {
$defattr{$a[0]} = 1;
} else {
$defattr{$a[0]} = $a[1];
}
return undef;
}
#####################################
sub
CommandSetstate($$)
{
my ($cl, $param) = @_;
my $ret = undef;
my @a = split(" ", $param, 2);
return "Usage: setstate <name> <state>" if(@a != 2);
return "Please define $a[0] first" if(!defined($defs{$a[0]}));
# Detailed state with timestamp
if($a[1] =~ m/^\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2} /) {
my @b = split(" ", $a[1], 4);
no strict "refs";
$ret = &{$devmods{$defs{$a[0]}{TYPE}}{StateFn}}
($defs{$a[0]}, "$b[0] $b[1]", $b[2], $b[3]);
use strict "refs";
$oldvalue{$a[0]}{TIME} = "$b[0] $b[1]";
$oldvalue{$a[0]}{VAL} = $b[2];
} else {
$defs{$a[0]}{STATE} = $a[1];
}
return $ret;
}
#####################################
sub
CommandSavefile($$)
{
my ($cl, $param) = @_;
$savefile = $param;
return undef;
}
#####################################
sub
CommandPidfile($$)
{
my ($cl, $param) = @_;
$pidfilename = $param;
return undef if(!$init_done);
return "$param: $!" if(!open(PID, ">$param"));
print PID $$ . "\n";
close(PID);
return undef;
}
#####################################
sub
CommandTrigger($$)
{
my ($cl, $param) = @_;
my ($dev, $state) = split(" ", $param, 2);
return "Usage: trigger <device> <state>" if(!$state);
return "Please define $dev first" if(!defined($defs{$dev}));
return DoTrigger($dev, $state);
}
#####################################
sub
CommandInform($$)
{
my ($cl, $param) = @_;
if(!$cl) {
return;
}
return "Usage: inform {on|off}" if($param !~ m/^(on|off)$/i);
$client{$cl}{inform} = ($param =~ m/on/i);
Log 4, "Setting inform to " . ($client{$cl}{inform} ? "on" : "off");
return undef;
}
#####################################
sub
CommandSleep($$)
{
my ($cl, $param) = @_;
return "Cannot interpret $param as seconds" if($param !~ m/^[0-9\.]+$/);
Log 4, "sleeping for $param";
select(undef, undef, undef, $param);
return undef;
}
#####################################
# 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();
return ($nextat-$now) if($now < $nextat);
$nextat = 0;
foreach my $i (keys %at) {
if($now >= $at{$i}{TIM}) {
my $skip = (defined($attr{$i}) && defined($attr{$i}{skip_next}));
if($skip) {
delete $attr{$i}{skip_next};
} else {
AnalyzeCommandChain(undef, $at{$i}{CMD});
}
my $count = $at{$i}{REP};
delete $at{$i};
if($count) {
$i =~ s/{\d+}/{$count}/ if($i =~ m/^\+?\*{/); # Replace the count }
CommandAt(undef, $i); # Recompute the next TIM
}
} else {
$nextat = $at{$i}{TIM} if(!$nextat || $nextat > $at{$i}{TIM});
}
}
#############
# Check the internal list.
foreach my $i (keys %intAt) {
my $tim = $intAt{$i}{TIM};
if($tim <= $now) {
no strict "refs";
&{$intAt{$i}{FN}}($intAt{$i}{ARG});
use strict "refs";
delete($intAt{$i});
}
$nextat = $tim if(!$nextat || $nextat > $tim);
}
return undef if(!$nextat);
$now = gettimeofday();
return ($now < $nextat) ? ($nextat-$now) : 0;
}
#####################################
sub
InternalTimer($$$)
{
my ($tim, $fn, $arg) = @_;
if(!$init_done) {
select(undef, undef, undef, $tim-gettimeofday());
no strict "refs";
&{$fn}($arg);
use strict "refs";
return;
}
$intAt{$intAtCnt}{TIM} = $tim;
$intAt{$intAtCnt}{FN} = $fn;
$intAt{$intAtCnt}{ARG} = $arg;
$intAtCnt++;
$nextat = $tim if(!$nextat || $nextat > $tim);
}
#####################################
sub
SignalHandling()
{
if ($^O ne "MSWin32") {
$SIG{'INT'} = sub { $sig_term = 1; };
$SIG{'QUIT'} = sub { $sig_term = 1; };
$SIG{'TERM'} = sub { $sig_term = 1; };
$SIG{'PIPE'} = 'IGNORE';
$SIG{'CHLD'} = 'IGNORE';
$SIG{'HUP'} = sub { CommandRereadCfg(undef, "") };
}
}
#####################################
sub
TimeNow()
{
my @t = localtime;
return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
$t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]);
}
#####################################
sub
CommandChain($$)
{
my ($retry, $list) = @_;
my $ov = $verbose;
my $oid = $init_done;
$init_done = 0;
$verbose = 1;
foreach my $cmd (@{$list}) {
for(my $n = 0; $n < $retry; $n++) {
Log 1, sprintf("Trying again $cmd (%d out of %d)", $n+1,$retry) if($n>0);
my $ret = AnalyzeCommand(undef, $cmd);
last if(!$ret || $ret !~ m/Timeout/);
}
}
$verbose = $ov;
$init_done = $oid;
}
#####################################
sub
ResolveDateWildcards($@)
{
my ($f, @t) = @_;
return $f if(!$f);
return $f if($f !~ m/%/); # Be fast if there is no wildcard
my $M = sprintf("%02d", $t[1]); $f =~ s/%M/$M/g;
my $H = sprintf("%02d", $t[2]); $f =~ s/%H/$H/g;
my $d = sprintf("%02d", $t[3]); $f =~ s/%d/$d/g;
my $m = sprintf("%02d", $t[4]+1); $f =~ s/%m/$m/g;
my $Y = sprintf("%04d", $t[5]+1900); $f =~ s/%Y/$Y/g;
my $w = sprintf("%d", $t[6]); $f =~ s/%w/$w/g;
my $j = sprintf("%03d", $t[7]+1); $f =~ s/%j/$j/g;
my $U = sprintf("%02d", int(($t[7]-$t[6]+6)/7)); $f =~ s/%U/$U/g;
my $V = sprintf("%02d", int(($t[7]-$t[6]+7)/7)+1); $f =~ s/%V/$V/g;
return $f;
}
sub
SemicolonEscape($)
{
my $cmd = shift;
$cmd =~ s/^[ \t]*//;
$cmd =~ s/[ \t]*$//;
if($cmd =~ m/^{.*}$/ || $cmd =~ m/^".*"$/) {
$cmd =~ s/;/;;/g
}
return $cmd;
}
sub
DoTrigger($$)
{
my ($dev, $ns) = @_;
return "" if(!defined($defs{$dev}));
if(defined($ns)) {
$defs{$dev}{CHANGED}[0] = $ns;
} elsif(!defined($defs{$dev}{CHANGED})) {
return "";
}
Log 5, "Triggering $dev";
my $max = int(@{$defs{$dev}{CHANGED}});
my $ret = "";
return "" if(defined($attr{$dev}) && defined($attr{$dev}{do_not_notify}));
for(my $i = 0; $i < $max; $i++) {
my $state = $defs{$dev}{CHANGED}[$i];
my $fe = "$dev:$state";
################
# Notify
foreach my $n (sort keys %ntfy) {
if($dev =~ m/^$n$/ || $fe =~ m/^$n$/) {
my $exec = $ntfy{$n};
$exec =~ s/%%/____/g;
$exec =~ s/%/$state/g;
$exec =~ s/____/%/g;
$exec =~ s/@@/____/g;
$exec =~ s/@/$dev/g;
$exec =~ s/____/@/g;
my $r = AnalyzeCommandChain(undef, $exec);
$ret .= " $r" if($r);
}
}
################
# Inform
foreach my $c (keys %client) {
next if(!$client{$c}{inform});
syswrite($client{$c}{fd}, "$defs{$dev}{TYPE} $dev $state\n");
}
}
################
# Log modules
foreach my $l (sort keys %logs) {
my $t = $logs{$l}{TYPE};
no strict "refs";
&{$logmods{$t}{LogFn}}($logs{$l}, $defs{$dev});
use strict "refs";
}
####################
# Used by triggered perl programs to check the old value
# Not suited for multi-valued devices (KS300, etc)
$oldvalue{$dev}{TIME} = TimeNow();
$oldvalue{$dev}{VAL} = $defs{$dev}{CHANGED}[0];
delete($defs{$dev}{CHANGED});
Log 3, "NTFY return: $ret" if($ret);
return $ret;
}
Reference in New Issue View Git Blame Copy Permalink