FHEM/fhem-mirror
2
0
Fork 0
mirror of https://github.com/fhem/fhem-mirror.git synced 2024-11-22 16:09:49 +00:00
Code Issues Releases Wiki Activity
280366a8b8
fhem-mirror/fhem/contrib/DS_Starter/98_Analyze.pm
nasseeder1 034db039e0 98_Analyze.pm: contrib 0.2.0 
git-svn-id: https://svn.fhem.de/fhem/trunk@24112 2b470e98-0d58-463d-a4d8-8e2adae1ed80
2021-03-28 18:28:38 +00:00

650 lines
20 KiB
Perl
Raw Blame History

########################################################################################################################
# $Id: $
#########################################################################################################################
# 98_Analyze.pm
#
# (c) 2020-2021 by Heiko Maaz
# e-mail: Heiko dot Maaz at t-online dot de
#
# This Module analyzes the data structure size in FHEM
#
# This script is part of fhem.
#
# Fhem is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# Fhem is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with fhem. If not, see <http://www.gnu.org/licenses/>.
#
#########################################################################################################################
#
# Definition: define <name> Analyze
#
# Example: define anaData Analyze
#
package FHEM::Analyze; ## no critic 'package'
use strict;
use warnings;
use utf8;
eval "use Devel::Size::Report qw(report_size track_size track_sizes entries_per_element hide_tracks); 1;" ## no critic 'eval'
or my $modReportAbsent = "Devel::Size::Report";
use Data::Dumper; # Perl Core module
use GPUtils qw(GP_Import GP_Export); # wird für den Import der FHEM Funktionen aus der fhem.pl benötigt
use FHEM::SynoModules::SMUtils qw( moduleVersion delReadings ); # Hilfsroutinen Modul
no if $] >= 5.017011, warnings => 'experimental::smartmatch';
eval "use FHEM::Meta;1" or my $modMetaAbsent = 1; ## no critic 'eval'
# no if $] >= 5.017011, warnings => 'experimental';
# Run before module compilation
BEGIN {
# Import from main::
GP_Import(
qw(
attr
modules
AttrVal
Debug
data
defs
IsDisabled
Log3
modules
CommandAttr
devspec2array
parseParams
ReadingsVal
RemoveInternalTimer
readingsBeginUpdate
readingsBulkUpdate
readingsEndUpdate
readingsSingleUpdate
readingFnAttributes
)
);
# Export to main context with different name
# my $pkg = caller(0);
# my $main = $pkg;
# $main =~ s/^(?:.+::)?([^:]+)$/main::$1\_/gx;
# foreach (@_) {
# *{ $main . $_ } = *{ $pkg . '::' . $_ };
# }
GP_Export(
qw(
Initialize
)
);
}
# Versions History intern
my %vNotesIntern = (
"0.2.0" => "28.03.2021 bug fix ",
"0.1.0" => "25.11.2020 initial "
);
# Voreinstellungen
my %hset = ( # Hash der Set-Funktion
allDevices => { fn => \&_setDeviceType },
deviceType => { fn => \&_setDeviceType },
xHashDetail => { fn => \&_setxHashDetail },
mainHash => { fn => \&_setMainHash },
);
my %hexcl = ( # Hash der excudierten Modultypen wegen Crash Devel::Size
TelegramBot => 1,
);
################################################################
sub Initialize {
my ($hash) = @_;
$hash->{DefFn} = \&Define;
$hash->{UndefFn} = \&Undef;
$hash->{DeleteFn} = \&Delete;
$hash->{SetFn} = \&Set;
$hash->{AttrFn} = \&Attr;
$hash->{FW_deviceOverview} = 1;
$hash->{AttrList} = "analyzeObject ".
"disable:1,0 ".
"largeObjectNum ".
"noOutput:1,0 ".
$readingFnAttributes;
FHEM::Meta::InitMod( __FILE__, $hash ) if(!$modMetaAbsent); # für Meta.pm (https://forum.fhem.de/index.php/topic,97589.0.html)
return;
}
################################################################
# Define
################################################################
sub Define {
my ($hash, $def) = @_;
my $name = $hash->{NAME};
return qq{ERROR - Perl module "$modReportAbsent" is missing. You need to install it first.} if($modReportAbsent);
my @a = split(/\s+/x, $def);
$hash->{HELPER}{MODMETAABSENT} = 1 if($modMetaAbsent); # Modul Meta.pm nicht vorhanden
CommandAttr(undef, "$name room SYSTEM");
my $params = {
hash => $hash,
notes => \%vNotesIntern,
useSMUtils => 1
};
use version 0.77; our $VERSION = moduleVersion ($params); # Versionsinformationen setzen
readingsBeginUpdate($hash);
readingsBulkUpdate ($hash, "state", "Initialized"); # Init state
readingsEndUpdate ($hash,1);
return;
}
################################################################
# Die Undef-Funktion wird aufgerufen wenn ein Gerät mit delete
# gelöscht wird oder bei der Abarbeitung des Befehls rereadcfg,
# der ebenfalls alle Geräte löscht und danach das
# Konfigurationsfile neu einliest.
# Funktion: typische Aufräumarbeiten wie das
# saubere Schließen von Verbindungen oder das Entfernen von
# internen Timern, sofern diese im Modul zum Pollen verwendet
# wurden.
################################################################
sub Undef {
my $hash = shift;
my $arg = shift;
return;
}
#######################################################################################################
# Mit der X_DelayedShutdown Funktion kann eine Definition das Stoppen von FHEM verzögern um asynchron
# hinter sich aufzuräumen.
# Je nach Rückgabewert $delay_needed wird der Stopp von FHEM verzögert (0|1).
# Sobald alle nötigen Maßnahmen erledigt sind, muss der Abschluss mit CancelDelayedShutdown($name) an
# FHEM zurückgemeldet werden.
#######################################################################################################
sub DelayedShutdown {
my $hash = shift;
my $name = $hash->{NAME};
my $type = $hash->{TYPE};
return 0;
}
#################################################################
# Wenn ein Gerät in FHEM gelöscht wird, wird zuerst die Funktion
# X_Undef aufgerufen um offene Verbindungen zu schließen,
# anschließend wird die Funktion X_Delete aufgerufen.
# Funktion: Aufräumen von dauerhaften Daten, welche durch das
# Modul evtl. für dieses Gerät spezifisch erstellt worden sind.
# Es geht hier also eher darum, alle Spuren sowohl im laufenden
# FHEM-Prozess, als auch dauerhafte Daten bspw. im physikalischen
# Gerät zu löschen die mit dieser Gerätedefinition zu tun haben.
#################################################################
sub Delete {
my $hash = shift;
my $arg = shift;
return;
}
################################################################
sub Attr {
my $cmd = shift;
my $name = shift;
my $aName = shift;
my $aVal = shift;
my $hash = $defs{$name};
my ($do,$val);
# $cmd can be "del" or "set"
# $name is device name
# aName and aVal are Attribute name and value
if ($aName eq "disable") {
if($cmd eq "set") {
$do = $aVal ? 1 : 0;
}
$do = 0 if($cmd eq "del");
$val = ($do ? "disabled" : "initialized");
if ($do) {
delReadings ($name, 0);
}
readingsBeginUpdate($hash);
readingsBulkUpdate ($hash, "state", $val);
readingsEndUpdate ($hash, 1);
}
if ($cmd eq "set") {
if ($aName =~ m/largeObjectNum/x) {
unless ($aVal =~ /^[0-9]+$/x) { return qq{The value of $aName is not valid. Use only integers 0 ... 9 !}; }
}
}
return;
}
#############################################################################################
# Setter
#############################################################################################
sub Set {
my ($hash, @a) = @_;
return "\"set X\" needs at least an argument" if ( @a < 2 );
my $name = shift @a;
my $opt = shift @a;
my $arg = join " ", map { my $p = $_; $p =~ s/\s//xg; $p; } @a; ## no critic 'Map blocks'
my $prop = shift @a;
return if(IsDisabled($name));
my $mods = join ",", sort keys (%modules);
my $noout = AttrVal ($name, "noOutput", 0);
my $ml = AttrVal ($name, "largeObjectNum", 5);
my $l = length $ml; # Anzahl Stellen (Länge) von largeObjectNum
my $setlist = "Unknown argument $opt, choose one of ";
$setlist .= "allDevices:noArg ".
"deviceType:$mods ".
"xHashDetail ".
"mainHash:\$data,\$attr,\$cmds "
;
my %sizes; # Hash zur Erstellung der Readings
my $params = {
hash => $hash,
name => $name,
opt => $opt,
arg => $arg,
prop => $prop,
sizes => \%sizes
};
if($hset{$opt} && defined &{$hset{$opt}{fn}}) {
my $ret = q{};
$ret = &{$hset{$opt}{fn}} ($params);
hide_tracks();
if(%sizes) {
delReadings ($name, 0);
my $k = 1;
readingsBeginUpdate ($hash);
for my $key (sort {$b <=> $a} keys %sizes) {
last if($k > $ml);
readingsBulkUpdate ($hash, sprintf("%0${l}d", $k)."_largestObject", "$key, $sizes{$key}");
$k++;
}
readingsBulkUpdate ($hash, "state", "done");
readingsEndUpdate ($hash,1);
}
undef %sizes;
return $ret if(!$noout);
return;
}
return "$setlist";
}
######################################################################################
# Setter deviceType
######################################################################################
sub _setDeviceType {
my $paref = shift;
my $name = $paref->{name};
my $opt = $paref->{opt};
my $prop = $paref->{prop};
my $sizes = $paref->{sizes}; # Hash zur Erstellung der Readings
my $allt = $prop // ".*";
my @devs = devspec2array ("TYPE=$allt");
my $ret = q{};
my $params = {
checkpars => { terse => 1 },
name => $name,
sizes => $sizes,
};
for my $dev (@devs) {
next if(!$defs{$dev});
$params->{txt} = "\$defs{$dev}";
$params->{obj} = $defs{$dev};
my $type = $defs{$dev}{TYPE};
my $excl = checkExcludes ($type); # problematische Module excludieren
if($excl) {
$ret .= $excl."\n";
next;
}
$ret .= check ($params);
}
return $ret;
}
######################################################################################
# Setter xHashDetail
######################################################################################
sub _setxHashDetail {
my $paref = shift;
my $name = $paref->{name};
my $opt = $paref->{opt};
my $arg = $paref->{arg};
my $sizes = $paref->{sizes}; # Hash zur Erstellung der Readings
$arg = AttrVal($name, "analyzeObject", $arg);
return qq{The command "$opt" needs an argument.} if (!$arg);
my ($a,$h) = parseParams($arg);
my ($htype) = @$a[0] =~ /^\$(.*?)(\{.*)?$/x;
$htype = $htype // "defs";
my $params = {
checkpars => { terse => 0 },
name => $name,
sizes => $sizes,
aref => $a,
htype => $htype,
};
my $ret = analyzeHashref ($params);
return $ret;
}
######################################################################################
# Setter mainHash
######################################################################################
sub _setMainHash {
my $paref = shift;
my $name = $paref->{name};
my $opt = $paref->{opt};
my $arg = $paref->{arg};
my $sizes = $paref->{sizes}; # Hash zur Erstellung der Readings
return qq{The command "$opt" needs an argument.} if (!$arg);
my ($a,$h) = parseParams($arg);
my $htype = substr @$a[0], 1;
my $params = {
checkpars => { terse => 0 },
name => $name,
sizes => $sizes,
aref => $a,
htype => $htype,
};
my $ret = analyzeHashref ($params);
return $ret;
}
######################################################################################
# analysiere eine Hash Referenz
######################################################################################
sub analyzeHashref {
my $paref = shift;
my $name = $paref->{name};
my $checkpars = $paref->{checkpars};
my $sizes = $paref->{sizes}; # Hash zur Erstellung der Readings
my $aref = $paref->{aref}; # Referenz zum auszuwertenden Objekt
my $htype = $paref->{htype} // return "got no Hash type"; # Typ des übergebenen Hash (defs, attr, ...)
Log3($name, 4, "$name - Hash type recognized: $htype");
my $ret = q{};
my @o = @$aref;
my ($ref,$txt);
if($o[0] =~ m/^\$$htype/x) {
$txt = $o[0];
$o[0] =~ s/^\$$htype//x;
$o[0] =~ s/^\{//x;
$o[0] =~ s/}$//x;
@o = split /}\{/x, $o[0];
}
else {
$txt = "\$$htype";
for my $i (0 .. $#o) {
$txt .= "{".$o[$i]."}";
}
}
no strict "refs"; ## no critic 'NoStrict'
*{'FHEM::Analyze::'.$htype} = *{'main::'.$htype};
use strict;
no strict "refs"; ## no critic 'NoStrict'
$ref = \%{$htype};
use strict;
$ret = checkRef ($name, $ref);
return $ret if($ret);
for my $a (0 .. $#o) {
$ret = checkRef ($name, $ref, $o[$a]);
return $ret if($ret);
$ref = $ref->{$o[$a]};
}
$paref->{txt} = $txt;
$paref->{obj} = $ref;
return check ($paref);
}
################################################################
# Analysesubroutine
################################################################
sub check {
my $paref = shift;
my $obj = $paref->{obj};
my $name = $paref->{name};
my $checkpars = $paref->{checkpars};
my $txt = $paref->{txt};
my $sizes = $paref->{sizes}; # Hashref zur Erstellung Readings
my @ret;
my $hash = $defs{$name};
my $ref = ref $obj;
my $rs = report_size ($obj, $checkpars);
my @elements = track_size ($obj); # für eigenes Parsing
my $entries = entries_per_element();
my $r = qq{Analyze result of object "$txt" (type: $ref) -> \n\n}.$rs;
push @ret,$r."\n";
my (%compnames,$compose);
for (my $i=0; $i<scalar(@elements); $i+=$entries) {
my ($rlvl, $rtype, $rsize, $roverh, $rname, $raddr, $rclass) = ($elements[$i+0],
$elements[$i+1],
$elements[$i+2],
$elements[$i+3],
$elements[$i+4],
$elements[$i+5],
$elements[$i+6]);
Log3($name, 5, "$name - $rlvl, type: $rtype, size: $rsize, overhead: $roverh, name: ".($rname // q{})." , addr: $raddr, class: ".($rclass // q{}));
if(!$rlvl) {
undef %compnames;
}
$compnames{$rlvl} = $rname // $txt;
for (my $k=0; $k<=$rlvl; $k++) {
$compose = $compnames{0} if($k == 0);
$compose .= "{".$compnames{$k}."}" if($k > 0);
}
$sizes->{$rsize} = $compose if($ref);
}
return join("",@ret);
};
######################################################################################
# check evtl. excludierte Typen
######################################################################################
sub checkExcludes {
my $type = shift;
if($hexcl{$type}) {
return qq{Sorry, devices of TYPE "$type" cannot be analyzed at the moment because of Devel::Size error.};
}
return;
}
######################################################################################
# check valide Referenz
######################################################################################
sub checkRef {
my $name = shift;
my $oref = shift;
my $obj = shift;
my $ref = q{};
my $val;
if ($obj) {
eval {$ref = ref $oref->{$obj}};
$val = $oref->{$obj};
}
else {
eval {$ref = ref $oref};
$val = $oref;
}
return if($ref ne q{}); # Referenz ok
my $ret = "No ref found. Try print value of the object:\n\n".Dumper $val;
Log3($name, 4, "$name - $ret");
return $ret;
}
1;
=pod
=item summary Module to check the size of FHEM data structure
=item summary_DE Modul zur Überprüfung der Größe der FHEM-Datenstruktur
=begin html
<a name="Analyze"></a>
<h3>Analyze</h3>
<ul>
</ul>
=end html
=begin html_DE
<a name="Analyze"></a>
<h3>Analyze</h3>
<ul>
</ul>
=end html_DE
=for :application/json;q=META.json 98_Analyze.pm
{
"abstract": "Module to check the size of FHEM data structure.",
"x_lang": {
"de": {
"abstract": "Modul zur Überprüfung der Größe der FHEM-Datenstruktur."
}
},
"keywords": [
"Analyze",
"Cannot fork",
"Memory",
"Data",
"Crash"
],
"version": "v1.1.1",
"release_status": "testing",
"author": [
"Heiko Maaz <heiko.maaz@t-online.de>"
],
"x_fhem_maintainer": [
"DS_Starter"
],
"x_fhem_maintainer_github": [
"nasseeder1"
],
"prereqs": {
"runtime": {
"requires": {
"FHEM": 5.00918799,
"perl": 5.014,
"Data::Dumper": 0,
"FHEM::SynoModules::SMUtils": 0,
"GPUtils": 0,
"Devel::Size::Report": 0,
"utf8": 0
},
"recommends": {
"FHEM::Meta": 0
},
"suggests": {
}
}
},
"resources": {
"x_wiki": {
"web": "https://wiki.fhem.de/wiki/Analyze_-_Analyse_von_FHEM_Datenstrukturen",
"title": "Analyze - Analyse von FHEM Datenstrukturen"
},
"repository": {
"x_dev": {
"type": "svn",
"url": "https://svn.fhem.de/trac/browser/trunk/fhem/contrib/DS_Starter",
"web": "https://svn.fhem.de/trac/browser/trunk/fhem/contrib/DS_Starter/98_Analyze.pm",
"x_branch": "dev",
"x_filepath": "fhem/contrib/",
"x_raw": "https://svn.fhem.de/fhem/trunk/fhem/contrib/DS_Starter/98_Analyze.pm"
}
}
}
}
=end :application/json;q=META.json
=cut
Reference in New Issue View Git Blame Copy Permalink