################################################################ #+$Id$ #+vim: ts=2:et # #+ (c) 2012 Copyright: Martin Fischer (m_fischer at gmx 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 # 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. # ################################################################ package main; use strict; use warnings; use Config; sub CommandFheminfo($$); ######################################## sub fheminfo_Initialize($$) { my %hash = ( Fn => "CommandFheminfo", Hlp => "[send],show or send Fhem statistics", ); $cmds{fheminfo} = \%hash; } ######################################## sub CommandFheminfo($$) { my ($cl,$param) = @_; # split arguments my @args = split(/ +/,$param); my $name = "fheminfo"; my %info; my $module = "HTTP::Request::Common"; my $err = "Missing perl module '$module'. Please install this module first."; if(!checkModule($module)) { Log 1, "$name $err"; return $err; } $module = "LWP::UserAgent"; if(!checkModule($module)) { Log 1, "$name $err"; return $err; } return "Unknown argument $args[0], usage: fheminfo [send]" if(@args && lc($args[0]) ne "send"); return "Won't send, as sendStatistics is set to 'never'." if(@args && lc($args[0]) eq "send" && lc(AttrVal("global","sendStatistics","")) eq "never"); my $branch = "DEVELOPMENT"; # UNUSED my $release = "5.6"; my $os = $^O; my $arch = $Config{"archname"}; my $perl = $^V; my $uniqueID = getUniqueId(); my $sendStatistics = AttrVal("global","sendStatistics",undef); my $moddir = $attr{global}{modpath}."/FHEM"; my $upTime = fhemUptime(); my %official_module; opendir(DH, $moddir) || return("$moddir: $!"); foreach my $file (grep /^controls.*.txt$/, readdir(DH)) { open(FH, "$moddir/$file") || next; while(my $l = ) { $official_module{$1} = 1 if($l =~ m+^UPD.* FHEM/\d\d_(.*).pm+); } close(FH); } closedir(DH); return "Can't read FHEM/controls_fhem.txt, execute update first." if(!%official_module); foreach my $d (sort keys %defs) { my $n = $defs{$d}{NAME}; my $t = $defs{$d}{TYPE}; my $m = "unknown"; $m = $defs{$d}{model} if( defined($defs{$d}{model}) ); $m = AttrVal($n,"model",$m); if($official_module{$t} && !$defs{$d}{TEMPORARY} && !$attr{$d}{ignore}) { $info{modules}{$t}{$n} = $m; } } $info{modules}{configDB}{configDB} = 'unknown' if (configDBUsed()); my $str; $str = "Fhem info:\n"; $str .= sprintf(" Release%*s: %s\n",2," ",$release); $str .= sprintf(" OS%*s: %s\n",7," ",$os); $str .= sprintf(" Arch%*s: %s\n",5," ",$arch); $str .= sprintf(" Perl%*s: %s\n",5," ",$perl); $str .= sprintf(" uniqueID%*s: %s\n",0," ",$uniqueID); $str .= sprintf(" upTime%*s: %s\n",3," ",$upTime); $str .= "\n"; my $contModules; my $contModels; my $modStr; my @modules = keys %{$info{modules}}; my $length = (reverse sort { $a <=> $b } map { length($_) } @modules)[0]; $str .= "Defined modules:\n"; foreach my $t (sort keys %{$info{modules}}) { my $c = scalar keys %{$info{modules}{$t}}; my @models; foreach my $n (sort keys %{$info{modules}{$t}}) { my $model = $info{modules}{$t}{$n}; if($model ne "unknown" && $t ne "dummy") { push(@models,$model) if(!grep {$_ =~ /$model/} @models); } } $str .= sprintf(" %s%*s: %d\n",$t,$length-length($t)+1," ",$c); if(@models != 0) { $modStr .= sprintf(" %s%*s: %s\n", $t,$length-length($t)+1," ", join(",",sort @models)); $contModels .= join(",",sort @models)."|"; } $contModules .= "$t:$c|"; } if($modStr) { $str .= "\n"; $str .= "Defined models per module:\n"; $str .= $modStr; } my $td = (lc(AttrVal("global", "sendStatistics", "")) eq "onupdate") ? "yes" : "no"; $str .= "\n"; $str .= "Transmitting this information during an update: $td\n"; $str .= "You can change this via the global attribute sendStatistics\n"; if(@args != 0 && $args[0] eq "send") { my $uri = "http://fhem.de/stats/statistics.cgi"; my $req = HTTP::Request->new("POST",$uri); $req->content_type("application/x-www-form-urlencoded"); my $contInfo; $contInfo = "Release:$release|"; $contInfo .= "Branch:$branch|"; $contInfo .= "OS:$os|"; $contInfo .= "Arch:$arch|"; $contInfo .= "Perl:$perl"; chop($contModules); if(!$contModels) { $req->content("uniqueID=$uniqueID&system=$contInfo&modules=$contModules"); } else { chop($contModels); $req->content("uniqueID=$uniqueID&system=$contInfo&modules=$contModules&models=$contModels"); } my $ua = LWP::UserAgent->new( agent => "Fhem/$release", timeout => 60); my $res = $ua->request($req); $str .= "\nserver response: "; if($res->is_success) { $str .= $res->content."\n"; } else { $str .= $res->status_line."\n"; } } return $str; } ######################################## sub checkModule($) { my $module = shift; eval("use $module"); if($@) { return(0); } else { return(1); } } sub fhemUptime() { my $diff = time - $fhem_started; my ($d,$h,$m,$ret); ($d,$diff) = _myDiv($diff,86400); ($h,$diff) = _myDiv($diff,3600); ($m,$diff) = _myDiv($diff,60); $ret = ""; $ret .= "$d days, " if($d > 1); $ret .= "1 day, " if($d == 1); $ret .= sprintf("%02s:%02s:%02s", $h, $m, $diff); return $ret; } sub _myDiv($$) { my ($p1,$p2) = @_; return (int($p1/$p2), $p1 % $p2); } 1; =pod =begin html

fheminfo

=end html =begin html_DE

fheminfo

=end html_DE =cut