# $Id$ package main; use strict; use warnings; use POSIX; use FHEM::Meta; sub Installer_Initialize($) { my ($modHash) = @_; $modHash->{SetFn} = "FHEM::Installer::Set"; $modHash->{GetFn} = "FHEM::Installer::Get"; $modHash->{DefFn} = "FHEM::Installer::Define"; $modHash->{NotifyFn} = "FHEM::Installer::Notify"; $modHash->{UndefFn} = "FHEM::Installer::Undef"; $modHash->{AttrFn} = "FHEM::Installer::Attr"; $modHash->{AttrList} = "disable:1,0 " . "disabledForIntervals " . "installerMode:update,developer " . "updateListReading:1,0 " . "updatePerlDualLifeModules:0,1 " . "updatePerlUsedModulesOnly:1,0 " . "installPerlReinstall:0,1 " . "installPerlNoTest:0,1 " . "installPerlEnforced:0,1 " . $readingFnAttributes; return FHEM::Meta::InitMod( __FILE__, $modHash ); } # define package package FHEM::Installer; use strict; use warnings; use POSIX; use FHEM::Meta; use GPUtils qw(GP_Import); use Data::Dumper; use Config; use ExtUtils::Installed; # Run before module compilation BEGIN { # Import from main:: GP_Import( qw( attr AttrVal cmds CommandAttr Debug defs deviceEvents devspec2array DoTrigger FW_webArgs gettimeofday init_done InternalTimer IsDisabled LoadModule Log Log3 maxNum modules packages readingsBeginUpdate readingsBulkUpdate readingsBulkUpdateIfChanged readingsEndUpdate readingsSingleUpdate ReadingsTimestamp ReadingsVal RemoveInternalTimer TimeNow Value ) ); } # try to use JSON::MaybeXS wrapper # for chance of better performance + open code eval { require JSON::MaybeXS; import JSON::MaybeXS qw( decode_json encode_json ); 1; }; if ($@) { $@ = undef; # try to use JSON wrapper # for chance of better performance eval { # JSON preference order local $ENV{PERL_JSON_BACKEND} = 'Cpanel::JSON::XS,JSON::XS,JSON::PP,JSON::backportPP' unless ( defined( $ENV{PERL_JSON_BACKEND} ) ); require JSON; import JSON qw( decode_json encode_json ); 1; }; if ($@) { $@ = undef; # In rare cases, Cpanel::JSON::XS may # be installed but JSON|JSON::MaybeXS not ... eval { require Cpanel::JSON::XS; import Cpanel::JSON::XS qw(decode_json encode_json); 1; }; if ($@) { $@ = undef; # In rare cases, JSON::XS may # be installed but JSON not ... eval { require JSON::XS; import JSON::XS qw(decode_json encode_json); 1; }; if ($@) { $@ = undef; # Fallback to built-in JSON which SHOULD # be available since 5.014 ... eval { require JSON::PP; import JSON::PP qw(decode_json encode_json); 1; }; if ($@) { $@ = undef; # Fallback to JSON::backportPP in really rare cases require JSON::backportPP; import JSON::backportPP qw(decode_json encode_json); 1; } } } } } # Load dependent FHEM modules as packages, # no matter if user also defined FHEM devices or not. # We want to use their functions here :-) #TODO let this make Meta.pm for me #LoadModule('apt'); #LoadModule('pypip'); LoadModule('npmjs'); our %pkgStatus = (); sub Define($$) { my ( $hash, $def ) = @_; my @a = split( "[ \t][ \t]*", $def ); # Initialize the module and the device return $@ unless ( FHEM::Meta::SetInternals($hash) ); use version 0.77; our $VERSION = FHEM::Meta::Get( $hash, 'version' ); my $name = $a[0]; my $host = $a[2] ? $a[2] : 'localhost'; Undef( $hash, undef ) if ( $hash->{OLDDEF} ); # modify $hash->{NOTIFYDEV} = "global,$name"; return "Existing instance: " . $modules{ $hash->{TYPE} }{defptr}{localhost}{NAME} if ( defined( $modules{ $hash->{TYPE} }{defptr}{localhost} ) ); $modules{ $hash->{TYPE} }{defptr}{localhost} = $hash; if ( $init_done && !defined( $hash->{OLDDEF} ) ) { # presets for FHEMWEB $attr{$name}{alias} = 'FHEM Installer Status'; $attr{$name}{devStateIcon} = '.*updates.available:security@red:outdated up.to.date:security@green:outdated .*outdated.*in.progress:system_fhem_reboot@orange .*in.progress:system_fhem_update@orange warning.*:message_attention@orange error.*:message_attention@red'; $attr{$name}{group} = 'Update'; $attr{$name}{icon} = 'system_fhem'; $attr{$name}{room} = 'System'; } readingsSingleUpdate( $hash, "state", "initialized", 1 ) if ( ReadingsVal( $name, 'state', 'none' ) ne 'none' ); return undef; } sub Undef($$) { my ( $hash, $arg ) = @_; my $name = $hash->{NAME}; if ( exists( $hash->{".fhem"}{subprocess} ) ) { my $subprocess = $hash->{".fhem"}{subprocess}; $subprocess->terminate(); $subprocess->wait(); } RemoveInternalTimer($hash); delete( $modules{ $hash->{TYPE} }{defptr}{localhost} ); return undef; } sub Attr(@) { my ( $cmd, $name, $attrName, $attrVal ) = @_; my $hash = $defs{$name}; if ( $attrName eq "disable" ) { if ( $cmd eq "set" and $attrVal eq "1" ) { RemoveInternalTimer($hash); readingsSingleUpdate( $hash, "state", "disabled", 1 ); Log3 $name, 3, "Installer ($name) - disabled"; } elsif ( $cmd eq "del" ) { Log3 $name, 3, "Installer ($name) - enabled"; } } elsif ( $attrName eq "disabledForIntervals" ) { if ( $cmd eq "set" ) { return "check disabledForIntervals Syntax HH:MM-HH:MM or 'HH:MM-HH:MM HH:MM-HH:MM ...'" unless ( $attrVal =~ /^((\d{2}:\d{2})-(\d{2}:\d{2})\s?)+$/ ); Log3 $name, 3, "Installer ($name) - disabledForIntervals"; readingsSingleUpdate( $hash, "state", "disabled", 1 ); } elsif ( $cmd eq "del" ) { Log3 $name, 3, "Installer ($name) - enabled"; readingsSingleUpdate( $hash, "state", "active", 1 ); } } return undef; } sub Notify($$) { my ( $hash, $dev ) = @_; my $name = $hash->{NAME}; return if ( IsDisabled($name) ); my $devname = $dev->{NAME}; my $devtype = $dev->{TYPE}; my $events = deviceEvents( $dev, 1 ); return if ( !$events ); Log3 $name, 5, "Installer ($name) - Notify: " . Dumper $events; if ( ( ( grep ( /^DEFINED.$name$/, @{$events} ) or grep ( /^DELETEATTR.$name.disable$/, @{$events} ) or grep ( /^ATTR.$name.disable.0$/, @{$events} ) ) and $devname eq 'global' and $init_done ) or ( ( grep ( /^INITIALIZED$/, @{$events} ) or grep ( /^REREADCFG$/, @{$events} ) or grep ( /^MODIFIED.$name$/, @{$events} ) ) and $devname eq 'global' ) ) { # Load metadata for all modules that are in use FHEM::Meta::Load(); # restore from packageList my $decode_json = eval { decode_json( ReadingsVal( $name, '.packageListPerl', '' ) ) }; unless ($@) { $hash->{".fhem"}{installer}{cpanversions} = $decode_json->{versions} if ( defined( $decode_json->{versions} ) ); $hash->{".fhem"}{installer}{listedPerlPackages} = $decode_json->{listedPerl} if ( defined( $decode_json->{listedPerl} ) ); $hash->{".fhem"}{installer}{outdatedPerlPackages} = $decode_json->{outdatedPerl} if ( defined( $decode_json->{outdatedPerl} ) ); } $decode_json = undef; # restore from installedList $decode_json = eval { decode_json( ReadingsVal( $name, '.installedListPerl', '' ) ) }; unless ($@) { $hash->{".fhem"}{installer}{installedPerlPackages} = $decode_json; } $decode_json = undef; # restore from uninstalledList $decode_json = eval { decode_json( ReadingsVal( $name, '.uninstalledListPerl', '' ) ); }; unless ($@) { $hash->{".fhem"}{installer}{uninstalledPerlPackages} = $decode_json; } $decode_json = undef; # restore from updatedList $decode_json = eval { decode_json( ReadingsVal( $name, '.updatedListPerl', '' ) ) }; unless ($@) { $hash->{".fhem"}{installer}{updatedPerlPackages} = $decode_json; } $decode_json = undef; # Trigger update if ( ReadingsVal( $name, 'cpanVersion', 'none' ) ne 'none' ) { ProcessUpdateTimer($hash); } else { $hash->{".fhem"}{installer}{cmd} = 'getCpanVersion'; AsynchronousExecuteFhemCommand($hash); } } if ( $devname eq $name and ( grep ( /^installedPerl:.successful$/, @{$events} ) or grep ( /^uninstalledPerl:.successful$/, @{$events} ) or grep ( /^updatedPerl:.successful$/, @{$events} ) ) ) { $hash->{".fhem"}{installer}{cmd} = 'outdatedPerl'; AsynchronousExecuteFhemCommand($hash); } return; } sub Set($$@) { my ( $hash, $name, @aa ) = @_; my ( $cmd, @args ) = @aa; my $ret; my $updatePerlDualLifeModules = AttrVal( $name, 'updatePerlDualLifeModules', 0 ); my $updatePerlUsedModulesOnly = AttrVal( $name, 'updatePerlUsedModulesOnly', 1 ); # outdatedPerl if ( lc($cmd) eq 'outdatedperl' ) { $hash->{".fhem"}{installer}{cmd} = $cmd; } # statusRequest elsif ( lc($cmd) eq 'statusrequest' ) { $hash->{".fhem"}{installer}{cmd} = 'getCpanVersion'; } # update elsif ( lc($cmd) eq 'updateperl' ) { return "Please run outdatedPerl check first" unless ( defined( $hash->{".fhem"}{installer}{outdatedPerlPackages} ) ); my $update; # generate explicit list for packages to update if ( @args == 0 || lc( $args[0] ) eq 'all' ) { undef @args; foreach ( keys %{ $hash->{".fhem"}{installer}{outdatedPerlPackages} } ) { next if ( $_ eq 'undefined' ); if ( $updatePerlDualLifeModules || !FHEM::Meta::ModuleIsPerlCore($_) ) { push @args, $_ . '@' . $hash->{".fhem"}{installer}{outdatedPerlPackages}{$_} {latest} if ( !$updatePerlUsedModulesOnly || defined( $FHEM::Meta::dependents{pkgs}{$_} ) ); } } } foreach my $pkgfull (@args) { next unless ( $pkgfull =~ /^(?:@([\w-]+)\/)?([\w\-\:]+)(?:@([\d\.=<>]+|latest))?$/ && defined( $hash->{".fhem"}{installer}{outdatedPerlPackages}{$2} ) ); $update .= " " if ($update); $update .= $2 . ( $3 && $3 ne 'latest' ? '@' . $3 : '' ); } return "Everything is up-to-date already" unless ($update); $hash->{".fhem"}{installer}{cmd} = "installPerl " . $update; $ret = "Update started in background"; } # installPerl elsif ( lc($cmd) eq 'installperl' ) { return "usage: $cmd " if ( @args < 1 ); $hash->{".fhem"}{installer}{cmd} = 'installPerl ' . join( " ", @args ); $ret = "Installation started in background"; } # uninstallPerl elsif ( lc($cmd) eq 'uninstallperl' ) { return "usage: $cmd " if ( @args < 1 ); return "cpanminus cannot be uninstalled from here" if ( grep ( m/^(?:@([\w-]+)\/)?(?:App::)?(cpanm(?:inus)?)(?:@([\d\.=<>]+|latest))?$/i, @args ) ); return "cpan-outdated cannot be uninstalled from here" if ( grep ( m/^(?:@([\w-]+)\/)?(?:App::)?(cpan\-?outdated)(?:@([\d\.=<>]+|latest))?$/i, @args ) ); $hash->{".fhem"}{installer}{cmd} = 'uninstallPerl ' . join( " ", @args ); $ret = "Deinstallation started in background"; } # return Usage: else { my $list = ''; if ( !defined( $hash->{".fhem"}{installer}{cpanversions} ) ) { $list = "installPerl:App::cpanminus statusRequest:noArg"; } elsif ( !defined( $hash->{".fhem"}{installer}{cpanversions}{cpanoutdated} ) ) { $list = "installPerl:App::cpanoutdated statusRequest:noArg"; } else { $list = "outdatedPerl:noArg"; $list .= " installPerl"; $list .= " uninstallPerl"; if ( defined( $hash->{".fhem"}{installer}{outdatedPerlPackages} ) and scalar keys %{ $hash->{".fhem"}{installer}{outdatedPerlPackages} } > 0 ) { my $update; foreach ( sort keys %{ $hash->{".fhem"}{installer}{outdatedPerlPackages} } ) { if ( ( $updatePerlDualLifeModules || !FHEM::Meta::ModuleIsPerlCore($_) ) && ( !$updatePerlUsedModulesOnly || defined( $FHEM::Meta::dependents{pkgs}{$_} ) ) ) { $update .= "," if ($update); $update .= $_; } } $list .= " updatePerl:all,$update" if ($update); } } return "Unknown argument $cmd, choose one of $list"; } AsynchronousExecuteFhemCommand($hash); return $ret if ($ret); return undef; } #TODO # - filter out FHEM command modules from FHEMWEB view (+attribute) -> difficult as not pre-loaded sub Get($$@) { my ( $hash, $name, @aa ) = @_; my ( $cmd, @args ) = @aa; my $updatePerlDualLifeModules = AttrVal( $name, 'updatePerlDualLifeModules', 0 ); my $updatePerlUsedModulesOnly = AttrVal( $name, 'updatePerlUsedModulesOnly', 1 ); if ( lc($cmd) eq 'showoutdatedperllist' ) { return "usage: $cmd" if ( @args != 0 ); my $ret = CreateOutdatedPerlList( $hash, $cmd ); return $ret; } elsif ( lc($cmd) eq 'showinstalledperllist' ) { return "usage: $cmd" if ( @args != 0 ); my $ret = CreateInstalledPerlList( $hash, $cmd ); return $ret; } elsif ( lc($cmd) eq 'checkprereqs' ) { my $ret = CreatePrereqsList( $hash, $cmd, @args ); return $ret; } elsif ( lc($cmd) eq 'search' ) { my $ret = CreateSearchList( $hash, $cmd, @args ); return $ret; } elsif ( lc($cmd) eq 'showmoduleinfo' ) { return "usage: $cmd MODULE" if ( @args != 1 ); my $ret = CreateMetadataList( $hash, $cmd, $args[0] ); return $ret; } elsif ( lc($cmd) eq 'showpackageinfo' ) { return "usage: $cmd PACKAGE" if ( @args != 1 ); my $ret = CreateMetadataList( $hash, $cmd, $args[0] ); return $ret; } elsif ( lc($cmd) eq 'zzgetmodulemeta.json' ) { return "usage: $cmd MODULE" if ( @args != 1 ); my $ret = CreateRawMetaJson( $hash, $cmd, $args[0] ); return $ret; } elsif ( lc($cmd) eq 'zzgetpackagemeta.json' ) { return "usage: $cmd PACKAGE" if ( @args != 1 ); my $ret = CreateRawMetaJson( $hash, $cmd, $args[0] ); return $ret; } elsif ( lc($cmd) eq 'showerrorlist' ) { return "usage: $cmd" if ( @args != 0 ); my $ret = CreateErrorList($hash); return $ret; } else { my $installerMode = AttrVal( $name, 'installerMode', 'update' ); my @fhemModules; foreach ( sort { "\L$a" cmp "\L$b" } keys %modules ) { next if ( $_ eq 'Global' ); push @fhemModules, $_ if ( $installerMode ne 'update' || defined( $modules{$_}{LOADED} ) ); } my $list = 'search' . ' showModuleInfo:FHEM,' . join( ',', @fhemModules ); if ( $installerMode eq 'developer' ) { my @fhemPackages; foreach ( sort { "\L$a" cmp "\L$b" } keys %packages ) { push @fhemPackages, $_; } $list .= ' showPackageInfo:' . join( ',', @fhemPackages ) . ' zzGetModuleMETA.json:FHEM,' . join( ',', @fhemModules ) . ' zzGetPackageMETA.json:' . join( ',', @fhemPackages ); } $list .= " checkPrereqs"; if ( $installerMode eq 'install' ) { my $dh; my $dir = $attr{global}{modpath}; if ( opendir( $dh, $dir ) ) { my $counter = 0; foreach my $fn ( grep { $_ ne "." && $_ ne ".." && !-d $_ && $_ =~ /\.cfg$/ } readdir($dh) ) { $list .= ':' unless ($counter); $list .= ',' if ($counter); $list .= $fn; $counter++; } closedir($dh); } } elsif ( $installerMode eq 'update' ) { $list .= ':noArg'; } my $counter = 0; if ( defined( $hash->{".fhem"}{installer}{outdatedPerlPackages} ) ) { foreach ( keys %{ $hash->{".fhem"}{installer}{outdatedPerlPackages} } ) { $counter++ if ( ( $updatePerlDualLifeModules || !FHEM::Meta::ModuleIsPerlCore($_) ) && ( !$updatePerlUsedModulesOnly || defined( $FHEM::Meta::dependents{pkgs}{$_} ) ) ); } } $list .= " showOutdatedPerlList:noArg" if ($counter); $list .= " showInstalledPerlList:noArg" if ( defined( $hash->{".fhem"}{installer}{listedPerlPackages} ) and scalar keys %{ $hash->{".fhem"}{installer}{listedPerlPackages} } > 0 ); $list .= " showErrorList:noArg" if ( defined( $hash->{".fhem"}{installer}{errors} ) and scalar @{ $hash->{".fhem"}{installer}{errors} } > 0 ); return "Unknown argument $cmd, choose one of $list"; } } sub Event ($$) { my $hash = shift; my $event = shift; my $name = $hash->{NAME}; return unless ( defined( $hash->{".fhem"}{installer}{cmd} ) && $hash->{".fhem"}{installer}{cmd} =~ m/^(install|uninstall|update)(?: (.+))/i ); my $cmd = $1; my $pkgs = $2; my $list; foreach my $package ( split / /, $pkgs ) { next unless ( $package =~ /^(?:@([\w-]+)\/)?([\w\-\:]+)(?:@([\d\.=<>]+|latest))?$/ ); $list .= " " if ($list); $list .= $2; } DoModuleTrigger( $hash, uc($event) . uc($cmd) . " $name $list" ); } sub DoModuleTrigger($$@) { my ( $hash, $eventString, $noreplace, $TYPE ) = @_; $hash = $defs{$hash} unless ( ref($hash) ); $noreplace = 1 unless ( defined($noreplace) ); $TYPE = $hash->{TYPE} unless ( defined($TYPE) ); return '' unless ( defined($TYPE) && defined( $modules{$TYPE} ) && defined($eventString) && $eventString =~ m/^([A-Za-z\d._]+)(?:\s+([A-Za-z\d._]+)(?:\s+(.+))?)?$/ ); my $event = $1; my $dev = $2; return "DoModuleTrigger() can only handle module related events" if ( ( $hash->{NAME} && $hash->{NAME} eq "global" ) || $dev eq "global" ); # This is a global event on module level return DoTrigger( "global", "$TYPE:$eventString", $noreplace ) unless ( $event =~ /^INITIALIZED|INITIALIZING|MODIFIED|DELETED|BEGIN(?:UPDATE|INSTALL|UNINSTALL)|END(?:UPDATE|INSTALL|UNINSTALL)$/ ); # This is a global event on module level and in device context return "$event: missing device name" if ( !defined($dev) || $dev eq '' ); return DoTrigger( "global", "$TYPE:$eventString", $noreplace ); } ################################### sub ProcessUpdateTimer($) { my $hash = shift; my $name = $hash->{NAME}; RemoveInternalTimer($hash); InternalTimer( gettimeofday() + 14400, "FHEM::Installer::ProcessUpdateTimer", $hash, 0 ); Log3 $name, 4, "Installer ($name) - stateRequestTimer: Call Request Timer"; unless ( IsDisabled($name) ) { if ( exists( $hash->{".fhem"}{subprocess} ) ) { Log3 $name, 2, "Installer ($name) - update in progress, process aborted."; return 0; } readingsSingleUpdate( $hash, "state", "ready", 1 ) if ( ReadingsVal( $name, 'state', 'none' ) eq 'none' or ReadingsVal( $name, 'state', 'none' ) eq 'initialized' ); if ( __ToDay() ne ( split( ' ', ReadingsTimestamp( $name, 'outdatedPerl', '1970-01-01' ) ) )[0] or ReadingsVal( $name, 'state', '' ) eq 'disabled' ) { $hash->{".fhem"}{installer}{cmd} = 'outdatedPerl'; AsynchronousExecuteFhemCommand($hash); } } } sub CleanSubprocess($) { my $hash = shift; my $name = $hash->{NAME}; delete( $hash->{".fhem"}{subprocess} ); Log3 $name, 4, "Installer ($name) - clean Subprocess"; } use constant POLLINTERVAL => 1; sub AsynchronousExecuteFhemCommand($) { require "SubProcess.pm"; my ($hash) = shift; my $name = $hash->{NAME}; my $subprocess = SubProcess->new( { onRun => \&OnRun } ); $subprocess->{installer} = $hash->{".fhem"}{installer}; $subprocess->{installer}{debug} = ( AttrVal( $name, 'verbose', 0 ) > 3 ? 1 : 0 ); $subprocess->{installer}{installPerlReinstall} = AttrVal( $name, 'installPerlReinstall', 0 ) ? '--reinstall ' : ''; $subprocess->{installer}{installPerlNoTest} = AttrVal( $name, 'installPerlNoTest', 0 ) ? '--notest ' : ''; $subprocess->{installer}{installPerlEnforced} = AttrVal( $name, 'installPerlEnforced', 0 ) ? '--force ' : ''; my $pid = $subprocess->run(); readingsSingleUpdate( $hash, 'state', 'command \'' . $hash->{".fhem"}{installer}{cmd} . '\' in progress', 1 ); if ( !defined($pid) ) { Log3 $name, 1, "Installer ($name) - Cannot execute command asynchronously"; CleanSubprocess($hash); readingsSingleUpdate( $hash, 'state', 'Cannot execute command asynchronously', 1 ); return undef; } Event( $hash, "BEGIN" ); Log3 $name, 4, "Installer ($name) - execute command asynchronously (PID= $pid)"; $hash->{".fhem"}{subprocess} = $subprocess; InternalTimer( gettimeofday() + POLLINTERVAL, "FHEM::Installer::PollChild", $hash, 0 ); Log3 $hash, 4, "Installer ($name) - control passed back to main loop."; } sub PollChild($) { my $hash = shift; my $name = $hash->{NAME}; if ( !exists( $hash->{".fhem"}{subprocess} ) || !ref( $hash->{".fhem"}{subprocess} ) || ref( $hash->{".fhem"}{subprocess} ) ne 'SubProcess' ) { my $emsg = defined( $hash->{".fhem"}{subprocess} ) && $hash->{".fhem"}{subprocess}{lasterror} ne '' ? '{"error":"' . $hash->{".fhem"}{subprocess}{lasterror} . '"}' : '{"error":"Child process suddenly ended"}'; Log3 $name, 5, "Installer ($name) - $emsg"; CleanSubprocess($hash); PreProcessing( $hash, $emsg ); return; } my $subprocess = $hash->{".fhem"}{subprocess}; my $json = $subprocess->readFromChild(); if ( !defined($json) ) { Log3 $name, 5, "Installer ($name) - still waiting (" . $subprocess->{lasterror} . ")."; InternalTimer( gettimeofday() + POLLINTERVAL, "FHEM::Installer::PollChild", $hash, 0 ); return; } else { Log3 $name, 4, "Installer ($name) - got result from asynchronous parsing."; $subprocess->wait(); Log3 $name, 4, "Installer ($name) - asynchronous finished."; CleanSubprocess($hash); PreProcessing( $hash, $json ); } } ###################################### # Begin Childprocess ###################################### sub OnRun() { my $subprocess = shift; my $response = ExecuteFhemCommand( $subprocess->{installer} ); my $json = eval { encode_json($response) }; if ($@) { Log3 'Installer OnRun', 3, "Installer - JSON error: $@"; $json = "{\"jsonerror\":\"$@\"}"; } $subprocess->writeToParent($json); } sub ExecuteFhemCommand($) { my $cmd = shift; my $installer = {}; $installer->{debug} = $cmd->{debug}; my $locale = 'LC_ALL=C'; my $sudo = $locale . ' sudo -n '; my $sudoH = $locale . ' sudo -H -n '; $installer->{cpanversions} = 'echo n | TEST=$(which cpanm) || echo "sh: command not found: cpanm"; which cpanm >/dev/null 2>&1 && sh -c "' . $sudoH . ' $(which cpanm) --version 2>&1" 2>&1'; $installer->{installperl} = 'echo n | sh -c "' . $sudoH . ' $(which cpanm) --quiet ' . $cmd->{installPerlReinstall} . $cmd->{installPerlNoTest} . $cmd->{installPerlEnforced} . '%PACKAGES%" 2>&1'; $installer->{uninstallperl} = 'echo n | sh -c "' . $sudoH . ' $(which cpanm) -U --quiet --force %PACKAGES%" 2>&1'; $installer->{outdatedperl} = 'echo n | ' . 'sh -c "' . $sudoH . ' $(which cpanm) --version 2>&1" 2>&1 && ' . 'L1=$(' . ' cpan-outdated --verbose 2>&1) && ' . '[ "$L1" != "" ] && [ "$L1" != "\n" ] && echo "@Outdated:\n$L1"; '; my $response; if ( $cmd->{cmd} =~ /^installperl (.+)/i ) { if ( not defined( $cmd->{cpanversions} ) or not defined( $cmd->{cpanversions}{cpanminus} ) ) { if ( $1 =~ /App::cpanminus/i ) { $installer->{installperl} = 'sh -c "( curl -fsSL https://git.io/cpanm 2>/dev/null || wget -qO- https://git.io/cpanm 2>/dev/null ) | ' . $sudoH . '$(which perl) - App::cpanminus >/dev/null 2>&1" 2>&1 ' . '&& TEST=$(which cpanm) || echo "sh: command not found: cpanm"; which cpanm >/dev/null 2>&1 && sh -c "' . $sudoH . ' $(which cpanm) --quiet App::cpanoutdated" 2>&1'; } } else { my @packages = ''; foreach my $package ( split / /, $1 ) { next unless ( $package =~ /^(?:@([\w-]+)\/)?([\w\-\:]+)(?:@([\d\.=<>]+|latest))?$/ ); push @packages, $2 . ( $3 && $3 ne 'latest' ? '@' . $3 : '' ); } my $pkglist = join( ' ', @packages ); return unless ( $pkglist ne '' ); $installer->{installperl} =~ s/%PACKAGES%/$pkglist/gi; } print qq($installer->{installperl}\n) if ( $installer->{debug} == 1 ); $response = CpanInstall($installer); } elsif ( $cmd->{cmd} =~ /^uninstallperl (.+)/i ) { my @packages = ''; foreach my $package ( split / /, $1 ) { next unless ( $package =~ /^(?:@([\w-]+)\/)?([\w\-\:]+)(?:@([\d\.=<>]+|latest))?$/ ); push @packages, $2; } my $pkglist = join( ' ', @packages ); return unless ( $pkglist ne '' ); $installer->{uninstallperl} =~ s/%PACKAGES%/$pkglist/gi; print qq($installer->{uninstallperl}\n) if ( $installer->{debug} == 1 ); $response = CpanUninstall($installer); } elsif ( lc( $cmd->{cmd} ) eq 'outdatedperl' ) { print qq($installer->{outdatedperl}\n) if ( $installer->{debug} == 1 ); $response = CpanOutdated($installer); } elsif ( lc( $cmd->{cmd} ) eq 'getcpanversion' ) { print qq($installer->{cpanversions}\n) if ( $installer->{debug} == 1 ); $response = GetCpanVersion($installer); } return $response; } sub GetCpanVersion($) { my $cmd = shift; my $h = {}; local $ENV{PATH} = __GetExtendedEnvPath(); my $p = `$cmd->{cpanversions}`; my $found = 0; my $isConfig = 0; my $isEnv = 0; my $isInc = 0; if ( $p && $p ne '' ) { foreach my $line ( split /\n/, $p ) { chomp($line); print qq($line\n) if ( $cmd->{debug} == 1 ); if ( $line =~ /^cpanm (?:\([A-za-z:]+\) )?version (\d+\.\d+) (\([\w\/\.\-]+\)).*/i ) { $h->{versions}{cpanminus} = $1; $found = 1; } elsif ( $line =~ /^perl version (\d+\.\d+) (\([\w\/\.\-]+\)).*/i ) { $h->{versions}{perl} = $1; } elsif ( $line =~ /^\s+\%Config:.*$/i ) { $isConfig = 1; } elsif ( $line =~ /^\s+\%ENV:.*$/i ) { $isConfig = 0; $isEnv = 1; } elsif ( $line =~ /^\s+\@INC:.*$/i ) { $isConfig = 0; $isEnv = 0; $isInc = 1; } elsif ($isConfig) { $line =~ s/^\s+//g; my @splitted = split( /=/, $line, 2 ); $h->{versions}{Config}{ $splitted[0] } = $splitted[1]; } elsif ($isEnv) { $line =~ s/^\s+//g; my @splitted = split( /=/, $line, 2 ); $h->{versions}{ENV}{ $splitted[0] } = $splitted[1]; } elsif ($isInc) { $line =~ s/^\s+//g; push @{ $h->{versions}{INC} }, $line unless ( $line =~ /^.+=.+$/i ); } # error elsif ( !$found ) { my $error = {}; if ( $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?not.found$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?\w+?: [^:]*?not.found: (\S+)$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?No.such.file.or.directory$/i ) { $error->{code} = "E404"; $error->{summary} = "Not Found - $3 is not installed"; $error->{detail} = $line; } elsif ( $line =~ m/^sudo: /i ) { my $error = {}; my $runningUser = getpwuid($<); my $cpanmbin = `which cpanm`; my $perlbin = `which perl`; $cpanmbin =~ s/\n//g; $perlbin =~ s/\n//g; $error->{code} = "E403"; $error->{summary} = "Forbidden - " . "passwordless sudo permissions required"; $error->{detail} = $line . "

" . "You may add the following lines to /etc/sudoers.d/$runningUser:\n" . "
"
                      . "  $runningUser ALL=(ALL) NOPASSWD:SETENV: "
                      . $cpanmbin . " *"
                      . "\n  $runningUser ALL=(ALL) NOPASSWD:SETENV: "
                      . $perlbin
                      . ' - App\:\:cpanminus'
                      . "
"; push @{ $h->{error} }, $error; last; } else { $error->{code} = "E501"; $error->{summary} = "Parsing error"; $error->{detail} = $p; } push @{ $h->{error} }, $error; last; } } } else { my $error; $error->{code} = "E500"; $error->{summary} = "Unknown error - Missing command output"; $error->{detail} = $p; push @{ $h->{error} }, $error; } # check for cpan-outdated my $cpanoutdated = `which cpan-outdated`; $h->{versions}{cpanoutdated} = 0 if ( $cpanoutdated =~ /^\/.+/ ); return $h; } sub CpanInstall($) { my $cmd = shift; my $h = {}; local $ENV{PATH} = __GetExtendedEnvPath(); eval { umask 0022; 1; }; my $p = `$cmd->{installperl}`; if ( $p && $p ne '' ) { $h->{success} = 0; foreach my $line ( split /\n/, $p ) { chomp($line); print qq($line\n) if ( $cmd->{debug} == 1 ); if ( $line =~ /^Successfully\s+(\S+)\s+([\S]+)-(\d+(?:\.\d+(?:_\d+)?)?).*$/i ) { my $r = $1; my $m = $2; my $v = $3; $m =~ s/-/::/g; $h->{installed}{$m}{result} = $r; $h->{installed}{$m}{version} = $v; $h->{success}++; } elsif ( $line =~ /^(\S+)\s+is\s+up\s+to\s+date.*\((\d+(?:\.\d+(?:_\d+)?)?)\).*$/i ) { my $m = $1; my $v = $2; $h->{installed}{$m}{result} = 'existing'; $h->{installed}{$m}{version} = $v; $h->{success}++; } elsif ( $line =~ /^(\d+)\s+(\S+)\s+(\S+)$/i ) { # ignore total result } elsif ( $line =~ /^\!\s+(.+)$/i ) { my $error = {}; my $sum = $1; $error->{code} = "E500"; $error->{code} = "E404" if ( $sum =~ /^Couldn't find.*/i ); $error->{summary} = $sum; push @{ $h->{error} }, $error; } elsif ( $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?not.found$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?\w+?: [^:]*?not.found: (\S+)$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?No.such.file.or.directory$/i ) { my $error = {}; $error->{code} = "E404"; $error->{summary} = "Not Found - $3 is not installed"; $error->{detail} = $line; push @{ $h->{error} }, $error; last; } elsif ( $line =~ m/^curl:.*Failed writing body.*$/i ) { my $error = {}; my $runningUser = getpwuid($<); my $cpanmbin = `which cpanm`; my $perlbin = `which perl`; $cpanmbin =~ s/\n//g; $perlbin =~ s/\n//g; $error->{code} = "E403"; $error->{summary} = "Forbidden - " . "passwordless sudo permissions required"; $error->{detail} = $line . "

" . "You may add the following lines to /etc/sudoers.d/$runningUser:\n" . "
"
                  . "  $runningUser ALL=(ALL) NOPASSWD:SETENV: "
                  . $perlbin
                  . ' - App\:\:cpanminus'
                  . "
"; push @{ $h->{error} }, $error; last; } elsif ( $line =~ m/^sudo: /i ) { my $error = {}; my $runningUser = getpwuid($<); my $cpanmbin = `which cpanm`; $cpanmbin =~ s/\n//g; $error->{code} = "E403"; $error->{summary} = "Forbidden - " . "passwordless sudo permissions required"; $error->{detail} = $line . "

" . "You may add the following lines to /etc/sudoers.d/$runningUser:\n" . "
"
                  . "  $runningUser ALL=(ALL) NOPASSWD:SETENV: "
                  . $cpanmbin . " *"
                  . "
"; push @{ $h->{error} }, $error; last; } else { my $error = {}; $error->{code} = "E501"; $error->{summary} = "Parsing error"; $error->{detail} = $line; push @{ $h->{error} }, $error; } } } else { my $error = {}; $error->{code} = "E500"; $error->{summary} = "Unknown error - Missing command output"; $error->{detail} = $p; push @{ $h->{error} }, $error; } return $h; } sub CpanUninstall($) { my $cmd = shift; my $h = {}; local $ENV{PATH} = __GetExtendedEnvPath(); my $p = `$cmd->{uninstallperl}`; if ( $p && $p ne '' ) { $h->{success} = 0; foreach my $line ( split /\n/, $p ) { chomp($line); print qq($line\n) if ( $cmd->{debug} == 1 ); next if ( $line eq '' ); if ( $line =~ /^Successfully\s+(\S+)\s+([\S]+).*$/i ) { $h->{uninstalled}{$2}{result} = $1; $h->{success}++; } elsif ( $line =~ /^\!\s(\S+)\s+is\s+not\s+found.*$/i ) { $h->{uninstalled}{$1}{result} = 'not installed'; $h->{success}++; } elsif ( $line =~ /^\!\s+(.+)$/i ) { my $error = {}; $error->{code} = "E500"; $error->{summary} = $1; push @{ $h->{error} }, $error; } elsif ( $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?not.found$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?\w+?: [^:]*?not.found: (\S+)$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?No.such.file.or.directory$/i ) { my $error = {}; $error->{code} = "E404"; $error->{summary} = "Not Found - $3 is not installed"; $error->{detail} = $line; push @{ $h->{error} }, $error; last; } elsif ( $line =~ m/^sudo: /i ) { my $error = {}; my $runningUser = getpwuid($<); my $cpanmbin = `which cpanm`; $cpanmbin =~ s/\n//g; $error->{code} = "E403"; $error->{summary} = "Forbidden - " . "passwordless sudo permissions required"; $error->{detail} = $line . "

" . "You may add the following lines to /etc/sudoers.d/$runningUser:\n" . "
"
                  . "  $runningUser ALL=(ALL) NOPASSWD:SETENV: "
                  . $cpanmbin . " *"
                  . "
"; push @{ $h->{error} }, $error; last; } elsif ( $line =~ m/^\s+.*$/ ) { # ignore lines that begin with spaces or are empty } else { my $error = {}; $error->{code} = "E501"; $error->{summary} = "Parsing error"; $error->{detail} = $line; push @{ $h->{error} }, $error; } } } else { my $error = {}; $error->{code} = "E500"; $error->{summary} = "Unknown error - Missing command output"; $error->{detail} = $p; push @{ $h->{error} }, $error; } return $h; } sub CpanOutdated($) { my $cmd = shift; my $h = {}; local $ENV{PATH} = __GetExtendedEnvPath(); my $p = `$cmd->{outdatedperl}`; my $found = 0; my $isConfig = 0; my $isEnv = 0; my $isInc = 0; my $isOutdated = 0; if ( $p && $p ne '' ) { foreach my $line ( split /\n/, $p ) { chomp($line); print qq($line\n) if ( $cmd->{debug} == 1 ); if ( $line =~ /^cpanm (?:\([A-za-z:]+\) )?version (\d+\.\d+) (\([\w\/\.\-]+\)).*/i ) { $h->{versions}{cpanminus} = $1; $found = 1; } elsif ( $line =~ /^perl version (\d+\.\d+) (\([\w\/\.\-]+\)).*/i ) { $h->{versions}{perl} = $1; } elsif ( $line =~ /^\s+\%Config:.*$/i ) { $isConfig = 1; } elsif ( $line =~ /^\s+\%ENV:.*$/i ) { $isConfig = 0; $isEnv = 1; } elsif ( $line =~ /^\s+\@INC:.*$/i ) { $isConfig = 0; $isEnv = 0; $isInc = 1; } elsif ( $line =~ /^\@Outdated:.*$/i ) { $isConfig = 0; $isEnv = 0; $isInc = 0; $isOutdated = 1; } elsif ($isConfig) { $line =~ s/^\s+//g; my @splitted = split( /=/, $line, 2 ); $h->{versions}{Config}{ $splitted[0] } = $splitted[1]; } elsif ($isEnv) { $line =~ s/^\s+//g; my @splitted = split( /=/, $line, 2 ); $h->{versions}{ENV}{ $splitted[0] } = $splitted[1]; } elsif ($isInc) { $line =~ s/^\s+//g; push @{ $h->{versions}{INC} }, $line; } elsif ($isOutdated) { if ( $line =~ /^([\w\:]+)\s+(\d+.\d+(?:_\d+)?)\s+(\d+.\d+(?:_\d+)?)\s+(\S+)$/ ) { $h->{outdatedPerl}{$1}{current} = $2; $h->{outdatedPerl}{$1}{latest} = $3; } else { $found = 0; } } # error if ( !$found ) { my $error = {}; my $runningUser = getpwuid($<); if ( $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?not.found$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?\w+?: [^:]*?not.found: (\S+)$/i or $line =~ m/(?:(\w+?): )?(?:(\w+? \d+): )?(\w+?): [^:]*?No.such.file.or.directory$/i ) { $error->{code} = "E404"; $error->{summary} = "Not Found - $3 is not installed"; $error->{detail} = $line; } else { $error->{code} = "E501"; $error->{summary} = "Parsing error"; $error->{detail} = $p; } push @{ $h->{error} }, $error; last; } } } else { my $error = {}; $error->{code} = "E500"; $error->{summary} = "Unknown error - Missing command output"; $error->{detail} = $p; push @{ $h->{error} }, $error; } # check for cpan-outdated my $cpanoutdated = `which cpan-outdated`; $h->{versions}{cpanoutdated} = 0 if ( $cpanoutdated =~ /^\/.+/ ); my ($ExtUtilsInstalled) = ExtUtils::Installed->new(); my (@modules) = $ExtUtilsInstalled->modules(); foreach (@modules) { next if ( $_ eq 'CPAN::outdated' ); my ($missing) = $ExtUtilsInstalled->validate($_); my $version = $ExtUtilsInstalled->version($_); $h->{listedPerl}{$_}{missing} = $missing if ($missing); eval { $h->{listedPerl}{$_}{version} = version->parse($version)->numify; 1; }; if ($@) { $h->{listedPerl}{$_}{version} = 0; $@ = undef; } } return $h; } #################################################### # End Childprocess #################################################### sub PreProcessing($$) { my ( $hash, $json ) = @_; my $name = $hash->{NAME}; my $decode_json = eval { decode_json($json) }; if ($@) { Log3 $name, 2, "Installer ($name) - JSON error: $@"; return; } Log3 $hash, 4, "Installer ($name) - JSON: $json"; if ( defined( $decode_json->{versions} ) && defined( $decode_json->{versions}{cpanminus} ) ) { $hash->{".fhem"}{installer}{cpanversions} = $decode_json->{versions}; } # safe result in hidden reading # to restore module state after reboot if ( $hash->{".fhem"}{installer}{cmd} eq 'outdatedPerl' ) { delete $hash->{".fhem"}{installer}{outdatedPerlPackages}; $hash->{".fhem"}{installer}{outdatedPerlPackages} = $decode_json->{outdatedPerl} if ( defined( $decode_json->{outdatedPerl} ) ); delete $hash->{".fhem"}{installer}{listedPerlPackages}; $hash->{".fhem"}{installer}{listedPerlPackages} = $decode_json->{listedPerl} if ( defined( $decode_json->{listedPerl} ) ); readingsSingleUpdate( $hash, '.packageListPerl', $json, 0 ); } elsif ( $hash->{".fhem"}{installer}{cmd} =~ /^install/ ) { delete $hash->{".fhem"}{installer}{installedPerlPackages}; $hash->{".fhem"}{installer}{installedPerlPackages} = $decode_json; readingsSingleUpdate( $hash, '.installedListPerl', $json, 0 ); } elsif ( $hash->{".fhem"}{installer}{cmd} =~ /^uninstall/ ) { delete $hash->{".fhem"}{installer}{uninstalledPerlPackages}; $hash->{".fhem"}{installer}{uninstalledPerlPackages} = $decode_json; readingsSingleUpdate( $hash, '.uninstalledListPerl', $json, 0 ); } elsif ( $hash->{".fhem"}{installer}{cmd} =~ /^update/ ) { delete $hash->{".fhem"}{installer}{updatedPerlPackages}; $hash->{".fhem"}{installer}{updatedPerlPackages} = $decode_json; readingsSingleUpdate( $hash, '.updatedListPerl', $json, 0 ); } if ( defined( $decode_json->{warning} ) or defined( $decode_json->{error} ) ) { $hash->{".fhem"}{installer}{'warnings'} = $decode_json->{warning} if ( defined( $decode_json->{warning} ) ); $hash->{".fhem"}{installer}{errors} = $decode_json->{error} if ( defined( $decode_json->{error} ) ); } else { delete $hash->{".fhem"}{installer}{'warnings'}; delete $hash->{".fhem"}{installer}{errors}; } WriteReadings( $hash, $decode_json ); } sub WriteReadings($$) { my ( $hash, $decode_json ) = @_; my $name = $hash->{NAME}; my $updatePerlDualLifeModules = AttrVal( $name, 'updatePerlDualLifeModules', 0 ); my $updatePerlUsedModulesOnly = AttrVal( $name, 'updatePerlUsedModulesOnly', 1 ); Log3 $hash, 4, "Installer ($name) - Write Readings"; Log3 $hash, 5, "Installer ($name) - " . Dumper $decode_json; readingsBeginUpdate($hash); if ( $hash->{".fhem"}{installer}{cmd} eq 'outdatedPerl' ) { readingsBulkUpdate( $hash, 'outdatedPerl', ( defined( $decode_json->{listedPerl} ) ? 'check completed' : 'check failed' ) ); $hash->{helper}{lastSync} = __ToDay(); } my $counter = 0; if ( $hash->{".fhem"}{installer}{cmd} eq 'outdatedPerl' ) { foreach ( keys %{ $decode_json->{outdatedPerl} } ) { $counter++ if ( ( $updatePerlDualLifeModules || !FHEM::Meta::ModuleIsPerlCore($_) ) && ( !$updatePerlUsedModulesOnly || defined( $FHEM::Meta::dependents{pkgs}{$_} ) ) ); } readingsBulkUpdateIfChanged( $hash, 'updatesAvailablePerl', $counter ); } readingsBulkUpdateIfChanged( $hash, 'updateListAsJSON', eval { encode_json( $hash->{".fhem"}{installer}{outdatedPerlPackages} ); } ) if ( AttrVal( $name, 'updateListReading', 'none' ) ne 'none' ); my $result = 'successful'; $result = 'error' if ( defined( $hash->{".fhem"}{installer}{errors} ) ); $result = 'warning' if ( defined( $hash->{".fhem"}{installer}{'warnings'} ) ); readingsBulkUpdate( $hash, 'installedPerl', $result ) if ( $hash->{".fhem"}{installer}{cmd} =~ /^installperl /i ); readingsBulkUpdate( $hash, 'uninstalledPerl', $result ) if ( $hash->{".fhem"}{installer}{cmd} =~ /^uninstallperl /i ); readingsBulkUpdate( $hash, 'updatedPerl', $result ) if ( $hash->{".fhem"}{installer}{cmd} =~ /^updateperl /i ); readingsBulkUpdateIfChanged( $hash, "cpanminusVersion", $decode_json->{versions}{cpanminus} ) if ( defined( $decode_json->{versions} ) && defined( $decode_json->{versions}{cpanminus} ) ); readingsBulkUpdateIfChanged( $hash, "perlVersion", $decode_json->{versions}{perl} ) if ( defined( $decode_json->{versions} ) && defined( $decode_json->{versions}{perl} ) ); if ( defined( $decode_json->{error} ) ) { readingsBulkUpdate( $hash, 'state', 'error \'' . $hash->{".fhem"}{installer}{cmd} . '\'' ); } elsif ( defined( $decode_json->{warning} ) ) { readingsBulkUpdate( $hash, 'state', 'warning \'' . $hash->{".fhem"}{installer}{cmd} . '\'' ); } else { if ( defined( $hash->{".fhem"}{installer}{outdatedPerlPackages} ) ) { foreach ( keys %{ $hash->{".fhem"}{installer}{outdatedPerlPackages} } ) { $counter++ if ( ( $updatePerlDualLifeModules || !FHEM::Meta::ModuleIsPerlCore($_) ) && ( !$updatePerlUsedModulesOnly || defined( $FHEM::Meta::dependents{pkgs}{$_} ) ) ); } } readingsBulkUpdate( $hash, 'state', ( $counter ? 'updates available' : 'up to date' ) ); } Event( $hash, "FINISH" ); readingsEndUpdate( $hash, 1 ); ProcessUpdateTimer($hash) if ( $hash->{".fhem"}{installer}{cmd} eq 'getCpanVersion' && !defined( $decode_json->{error} ) ); } sub CreateErrorList($) { my $hash = shift; my @ret; my $errors; my $html = defined( $hash->{CL} ) && $hash->{CL}{TYPE} eq "FHEMWEB" ? 1 : 0; $errors = $hash->{".fhem"}{installer}{errors}; # disable automatic links to FHEM devices delete $FW_webArgs{addLinks}; my $header = ''; my $footer = ''; if ($html) { $header = ''; $footer = ''; } my $blockOpen = ''; my $tTitleOpen = ''; my $tTitleClose = ''; my $tOpen = ''; my $tCOpen = ''; my $tCClose = ''; my $tHOpen = ''; my $tHClose = ''; my $tBOpen = ''; my $tBClose = ''; my $tFOpen = ''; my $tFClose = ''; my $trOpen = ''; my $trOpenEven = ''; my $trOpenOdd = ''; my $thOpen = ''; my $thOpen2 = ''; my $thOpen3 = ''; my $tdOpen = ''; my $tdOpen2 = ''; my $tdOpen3 = ''; my $strongOpen = ''; my $strongClose = ''; my $tdClose = "\t\t\t"; my $thClose = "\t\t\t"; my $trClose = ''; my $tClose = ''; my $blockClose = ''; my $colorRed = ''; my $colorGreen = ''; my $colorClose = ''; if ($html) { $blockOpen = '
'; $tTitleOpen = ''; $tTitleClose = ''; $tOpen = ''; $tCOpen = ''; $tHOpen = ''; $tHClose = ''; $tBOpen = ''; $tBClose = ''; $tFOpen = ''; $tFClose = ''; $trOpen = ''; $trOpenEven = ''; $trOpenOdd = ''; $thOpen = ''; $thClose = ''; $trClose = ''; $tClose = '
'; $tCClose = '
'; $thOpen2 = ''; $thOpen3 = ''; $tdOpen = ''; $tdOpen2 = ''; $tdOpen3 = ''; $strongOpen = ''; $strongClose = ''; $tdClose = '
'; $blockClose = '
'; $colorRed = ''; $colorGreen = ''; $colorClose = ''; } my $space = $html ? ' ' : ' '; my $lb = $html ? '
' : "\n"; my $lang = lc( AttrVal( $hash->{NAME}, 'language', AttrVal( 'global', 'language', 'EN' ) ) ); my $FW_CSRF = ( defined( $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} ) ? '&fwcsrf=' . $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} : '' ); if ( ref($errors) eq "ARRAY" && scalar @{$errors} > 0 ) { push @ret, $blockOpen . $tOpen . $tCOpen . 'Error List' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'No.' . $thClose; push @ret, $thOpen . 'Error Code' . $thClose; push @ret, $thOpen . 'Description' . $thClose; push @ret, $trClose . $tHClose; my $linecount = 1; foreach my $error ( sort { "\L$a" cmp "\L$b" } @{$errors} ) { my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; $l .= $tdOpen . $linecount . $tdClose; $l .= $tdOpen . $error->{code} . $tdClose; $l .= $tdOpen . $error->{summary} . ( defined( $error->{detail} ) && $error->{detail} ne '' ? $lb . $lb . $strongOpen . 'Detail:' . $strongClose . $lb . $error->{detail} : '' ) . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } push @ret, $tClose . $blockClose; } else { push @ret, 'No errors occured during last command.'; } return $header . join( "\n", @ret ) . $footer; } sub CreateInstalledPerlList($$) { my ( $hash, $getCmd ) = @_; my @ret; my $packages; my $html = defined( $hash->{CL} ) && $hash->{CL}{TYPE} eq "FHEMWEB" ? 1 : 0; $packages = $hash->{".fhem"}{installer}{listedPerlPackages}; # disable automatic links to FHEM devices delete $FW_webArgs{addLinks}; my $header = ''; my $footer = ''; if ($html) { $header = ''; $footer = ''; } my $blockOpen = ''; my $tTitleOpen = ''; my $tTitleClose = ''; my $tOpen = ''; my $tCOpen = ''; my $tCClose = ''; my $tHOpen = ''; my $tHClose = ''; my $tBOpen = ''; my $tBClose = ''; my $tFOpen = ''; my $tFClose = ''; my $trOpen = ''; my $trOpenEven = ''; my $trOpenOdd = ''; my $thOpen = ''; my $thOpen2 = ''; my $thOpen3 = ''; my $tdOpen = ''; my $tdOpen2 = ''; my $tdOpen3 = ''; my $strongOpen = ''; my $strongClose = ''; my $tdClose = "\t\t\t"; my $thClose = "\t\t\t"; my $trClose = ''; my $tClose = ''; my $blockClose = ''; my $colorRed = ''; my $colorGreen = ''; my $colorClose = ''; if ($html) { $blockOpen = '
'; $tTitleOpen = ''; $tTitleClose = ''; $tOpen = ''; $tCOpen = ''; $tHOpen = ''; $tHClose = ''; $tBOpen = ''; $tBClose = ''; $tFOpen = ''; $tFClose = ''; $trOpen = ''; $trOpenEven = ''; $trOpenOdd = ''; $thOpen = ''; $thClose = ''; $trClose = ''; $tClose = '
'; $tCClose = '
'; $thOpen2 = ''; $thOpen3 = ''; $tdOpen = ''; $tdOpen2 = ''; $tdOpen3 = ''; $strongOpen = ''; $strongClose = ''; $tdClose = '
'; $blockClose = '
'; $colorRed = ''; $colorGreen = ''; $colorClose = ''; } my $space = $html ? ' ' : ' '; my $lb = $html ? '
' : "\n"; my $lang = lc( AttrVal( $hash->{NAME}, 'language', AttrVal( 'global', 'language', 'EN' ) ) ); my $FW_CSRF = ( defined( $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} ) ? '&fwcsrf=' . $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} : '' ); if ( ref($packages) eq "HASH" && scalar keys %{$packages} > 0 ) { push @ret, $blockOpen . $tOpen . $tCOpen . 'Installed Perl Packages' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Version' . $thClose; push @ret, $trClose . $tHClose; my $linecount = 1; foreach my $package ( sort { "\L$a" cmp "\L$b" } keys %{$packages} ) { next if ( $package eq "undefined" ); my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; $l .= $tdOpen . $package . $tdClose; $l .= $tdOpen . ( defined( $packages->{$package}{version} ) && $packages->{$package}{version} ? $packages->{$package}{version} : '?' ) . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } push @ret, $tClose . $blockClose; } else { push @ret, 'No installed Perl packages found.'; } return $header . join( "\n", @ret ) . $footer; } sub CreateOutdatedPerlList($$) { my ( $hash, $getCmd ) = @_; my @ret; my $packages; my $html = defined( $hash->{CL} ) && $hash->{CL}{TYPE} eq "FHEMWEB" ? 1 : 0; $packages = $hash->{".fhem"}{installer}{outdatedPerlPackages}; # disable automatic links to FHEM devices delete $FW_webArgs{addLinks}; my $header = ''; my $footer = ''; if ($html) { $header = ''; $footer = ''; } my $blockOpen = ''; my $tTitleOpen = ''; my $tTitleClose = ''; my $tOpen = ''; my $tCOpen = ''; my $tCClose = ''; my $tHOpen = ''; my $tHClose = ''; my $tBOpen = ''; my $tBClose = ''; my $tFOpen = ''; my $tFClose = ''; my $trOpen = ''; my $trOpenEven = ''; my $trOpenOdd = ''; my $thOpen = ''; my $thOpen2 = ''; my $thOpen3 = ''; my $tdOpen = ''; my $tdOpen2 = ''; my $tdOpen3 = ''; my $strongOpen = ''; my $strongClose = ''; my $tdClose = "\t\t\t"; my $thClose = "\t\t\t"; my $trClose = ''; my $tClose = ''; my $blockClose = ''; my $colorRed = ''; my $colorGreen = ''; my $colorClose = ''; if ($html) { $blockOpen = '
'; $tTitleOpen = ''; $tTitleClose = ''; $tOpen = ''; $tCOpen = ''; $tHOpen = ''; $tHClose = ''; $tBOpen = ''; $tBClose = ''; $tFOpen = ''; $tFClose = ''; $trOpen = ''; $trOpenEven = ''; $trOpenOdd = ''; $thOpen = ''; $thClose = ''; $trClose = ''; $tClose = '
'; $tCClose = '
'; $thOpen2 = ''; $thOpen3 = ''; $tdOpen = ''; $tdOpen2 = ''; $tdOpen3 = ''; $strongOpen = ''; $strongClose = ''; $tdClose = '
'; $blockClose = '
'; $colorRed = ''; $colorGreen = ''; $colorClose = ''; } my $space = $html ? ' ' : ' '; my $lb = $html ? '
' : "\n"; my $lang = lc( AttrVal( $hash->{NAME}, 'language', AttrVal( 'global', 'language', 'EN' ) ) ); my $FW_CSRF = ( defined( $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} ) ? '&fwcsrf=' . $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} : '' ); if ( ref($packages) eq "HASH" ) { my $updatePerlDualLifeModules = AttrVal( $hash->{NAME}, 'updatePerlDualLifeModules', 0 ); my $updatePerlUsedModulesOnly = AttrVal( $hash->{NAME}, 'updatePerlUsedModulesOnly', 1 ); my $counter = 0; foreach ( keys %{$packages} ) { $counter++ if ( ( $updatePerlDualLifeModules || !FHEM::Meta::ModuleIsPerlCore($_) ) && ( !$updatePerlUsedModulesOnly || defined( $FHEM::Meta::dependents{pkgs}{$_} ) ) ); } if ($counter) { push @ret, $blockOpen . $tOpen . $tCOpen . 'Outdated Perl Packages' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Current Version' . $thClose; push @ret, $thOpen . 'Latest Version' . $thClose; push @ret, $trClose . $tHClose; my $linecount = 1; foreach my $package ( sort { "\L$a" cmp "\L$b" } keys %{$packages} ) { next if ( $package eq "undefined" ); next if ( ( !$updatePerlDualLifeModules && FHEM::Meta::ModuleIsPerlCore($package) ) || ( $updatePerlUsedModulesOnly && !defined( $FHEM::Meta::dependents{pkgs}{$package} ) ) ); my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; $l .= $tdOpen . $package . $tdClose; $l .= $tdOpen . ( defined( $packages->{$package}{current} ) ? $packages->{$package}{current} : '?' ) . $tdClose; $l .= $tdOpen . ( defined( $packages->{$package}{latest} ) ? $packages->{$package}{latest} : '?' ) . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } else { push @ret, 'No outdated Perl packages found.' } } return $header . join( "\n", @ret ) . $footer; } sub CreatePrereqsList { my $hash = shift; my $getCmd = shift; my $cfgfile = shift; my $mode = ( $cfgfile && $cfgfile eq '1' ? 'all' : ( $cfgfile ? 'file' : 'live' ) ); $mode = 'list' if ( $cfgfile && defined( $modules{$cfgfile} ) ); my @defined; if ( $mode eq 'live' || $mode eq 'all' ) { foreach ( keys %modules ) { next unless ( $mode eq 'all' || defined( $modules{$_}{LOADED} ) ); push @defined, $_; } } elsif ( $mode eq 'file' ) { @defined = __GetDefinedModulesFromFile($cfgfile); return 'File ' . $cfgfile . ' does not seem to contain any FHEM device configuration' unless ( @defined > 0 ); } elsif ( $mode eq 'list' ) { @defined = @_; unshift @defined, $cfgfile; } # disable automatic links to FHEM devices delete $FW_webArgs{addLinks}; my @ret; my $html = defined( $hash->{CL} ) && $hash->{CL}{TYPE} eq "FHEMWEB" ? 1 : 0; my $header = ''; my $footer = ''; if ($html) { $header = ''; $footer = ''; } my $blockOpen = ''; my $tTitleOpen = ''; my $tTitleClose = ''; my $tOpen = ''; my $tCOpen = ''; my $tCClose = ''; my $tHOpen = ''; my $tHClose = ''; my $tBOpen = ''; my $tBClose = ''; my $tFOpen = ''; my $tFClose = ''; my $trOpen = ''; my $trOpenEven = ''; my $trOpenOdd = ''; my $thOpen = ''; my $thOpen2 = ''; my $thOpen3 = ''; my $tdOpen = ''; my $tdOpen1 = ''; my $tdOpen2 = ''; my $tdOpen3 = ''; my $tdOpen4 = ''; my $strongOpen = ''; my $strongClose = ''; my $tdClose = "\t\t\t"; my $thClose = "\t\t\t"; my $trClose = ''; my $tClose = ''; my $blockClose = ''; my $colorRed = ''; my $colorGreen = ''; my $colorClose = ''; if ($html) { $blockOpen = '
'; $tTitleOpen = ''; $tTitleClose = ''; $tOpen = ''; $tCOpen = ''; $tHOpen = ''; $tHClose = ''; $tBOpen = ''; $tBClose = ''; $tFOpen = ''; $tFClose = ''; $trOpen = ''; $trOpenEven = ''; $trOpenOdd = ''; $thOpen = ''; $thClose = ''; $trClose = ''; $tClose = '
'; $tCClose = '
'; $thOpen2 = ''; $thOpen3 = ''; $tdOpen = ''; $tdOpen1 = ''; $tdOpen2 = ''; $tdOpen3 = ''; $tdOpen4 = ''; $strongOpen = ''; $strongClose = ''; $tdClose = '
'; $blockClose = '
'; $colorRed = ''; $colorGreen = ''; $colorClose = ''; } my $space = $html ? ' ' : ' '; my $lb = $html ? '
' : "\n"; my $lang = lc( AttrVal( $hash->{NAME}, 'language', AttrVal( 'global', 'language', 'EN' ) ) ); my $FW_CSRF = ( defined( $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} ) ? '&fwcsrf=' . $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} : '' ); ######## # Getting Perl prereqs LoadInstallStatusPerl( $defined[0] eq '1' ? 1 : \@defined ); my $found = 0; my $foundRequired = 0; my $foundRecommended = 0; my $foundSuggested = 0; my $foundRequiredPerl = 0; my $foundRecommendedPerl = 0; my $foundSuggestedPerl = 0; my $foundRequiredNodejs = 0; my $foundRecommendedNodejs = 0; my $foundSuggestedNodejs = 0; my $foundRequiredPython = 0; my $foundRecommendedPython = 0; my $foundSuggestedPython = 0; # Display prereqs foreach my $mAttr (qw(required recommended suggested)) { foreach my $area (qw(Perl Node.js Python)) { next unless ( defined( $pkgStatus{$mAttr} ) && defined( $pkgStatus{$mAttr}{$area} ) && keys %{ $pkgStatus{$mAttr}{$area} } > 0 ); my $linecount = 1; my $importance = ucfirst($mAttr); foreach my $item ( sort { "\L$a" cmp "\L$b" } keys %{ $pkgStatus{$mAttr}{$area} } ) { my $linkmod = ''; my $inScope = 0; foreach my $modName ( sort { "\L$a" cmp "\L$b" } @{ $pkgStatus{$mAttr}{$area}{$item}{modules} } ) { # check if this package is used by any # module that is in install scope if ( grep ( /^$modName$/, @defined ) ) { $inScope = 1; } $linkmod .= ', ' unless ( $linkmod eq '' ); if ($html) { $linkmod .= '' . ( $modName eq 'Global' ? 'FHEM' : $modName ) . ''; } else { $linkmod .= ( $modName eq 'Global' ? 'FHEM' : $modName ); } } next unless ($inScope); $found++; $foundRequired++ if ( $mAttr eq 'required' ); $foundRecommended++ if ( $mAttr eq 'recommended' ); $foundSuggested++ if ( $mAttr eq 'suggested' ); $foundRequiredPerl++ if ( $area eq 'Perl' && $mAttr eq 'required' ); $foundRecommendedPerl++ if ( $area eq 'Perl' && $mAttr eq 'recommended' ); $foundSuggestedPerl++ if ( $area eq 'Perl' && $mAttr eq 'suggested' ); $foundRequiredNodejs++ if ( $area eq 'Node.js' && $mAttr eq 'required' ); $foundRecommendedNodejs++ if ( $area eq 'Node.js' && $mAttr eq 'recommended' ); $foundSuggestedNodejs++ if ( $area eq 'Node.js' && $mAttr eq 'suggested' ); $foundRequiredPython++ if ( $area eq 'Python' && $mAttr eq 'required' ); $foundRecommendedPython++ if ( $area eq 'Python' && $mAttr eq 'recommended' ); $foundSuggestedPython++ if ( $area eq 'Python' && $mAttr eq 'suggested' ); my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $linkitem = $item; $linkitem = '' . $item . '' if ($html); my $action = ''; $l .= $tdOpen . $linkitem . ( $pkgStatus{$mAttr}{$area}{$item}{status} eq 'outdated' ? ' (wanted version: ' . $pkgStatus{$mAttr}{$area}{$item}{version} . ')' : '' ) . $tdClose; $l .= $tdOpen . $area . $tdClose; $l .= $tdOpen . $linkmod . $tdClose; $l .= $tdOpen . $action . $tdClose if ($html); $l .= $trClose; if ( $linecount == 1 ) { push @ret, $trOpen . $tdOpen . ( $html ? '' : '' ) . $blockOpen . $tOpen . $tCOpen . $importance . $tCClose; push @ret, $tHOpen . $trOpen; push @ret, $thOpen . 'Item' . $thClose; push @ret, $thOpen . 'Type' . $thClose; push @ret, $thOpen . 'Used by' . $thClose; push @ret, $thOpen . 'Action' . $thClose if ($html); push @ret, $trClose . $tHClose . $tBOpen; } push @ret, $l; $linecount++; } if ( $linecount > 1 ) { my $action = ''; push @ret, ( $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd ) . $tdOpen3 . $tdClose . $tdOpen1 . $action . $tdClose . $trClose if ($html); push @ret, $tBClose; my $descr = 'Required dependencies ' . $strongOpen . 'must' . $strongClose . ' be installed for the listed FHEM modules to work.'; $descr = 'Recommended dependencies are ' . $strongOpen . 'strongly encouraged' . $strongClose . ' and should be installed for full functionality of the listed FHEM modules, except in resource constrained environments.' if ( $importance eq 'Recommended' ); $descr = 'Suggested dependencies are ' . $strongOpen . 'optional' . $strongClose . ', but are suggested for enhanced operation of the listed FHEM modules.' if ( $importance eq 'Suggested' ); push @ret, $tFOpen . ( $html ? $tdOpen4 : $tdOpen3 ) . $descr . $tFClose; push @ret, $tClose . $blockClose . $tdClose . $trClose; } } } if ($found) { push @ret, $tBClose; if ( defined( $pkgStatus{Perl}{analyzed} ) ) { push @ret, $tFOpen . $trOpen . $tdOpen . $strongOpen . 'Hint:' . $strongClose . ' Some of the FHEM modules in use do not provide Perl prerequisites from its metadata.' . $lb; if ( $pkgStatus{Perl}{analyzed} == 1 ) { push @ret, 'This check is based on automatic source code analysis and can be incorrect.' . ' Suggested Perl items may still be required if the module author had decided to implement some own dependency and/or error handling like returning an informative message instead of the original Perl error message.'; } elsif ( $pkgStatus{Perl}{analyzed} == 2 ) { push @ret, 'This check may be incomplete until you ' . ( $html ? 'click here to install Perl::PrereqScanner::NotQuiteLite ' : 'install Perl::PrereqScanner::NotQuiteLite ' ) . 'for automatic source code analysis.'; } push @ret, $tdClose . $trClose . $tFClose; } unshift @ret, $lb . $lb . $tdClose . $trClose; unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundSuggested . ' suggested ' . ( $foundSuggested > 1 ? 'items' : 'item' ) . ( $html ? '' : '' ) if ($foundSuggested); unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundRecommended . ' recommended ' . ( $foundRecommended > 1 ? 'items' : 'item' ) . ( $html ? '' : '' ) if ($foundRecommended); unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundRequired . ' required ' . ( $foundRequired > 1 ? 'items' : 'item' ) . ( $html ? '' : '' ) if ($foundRequired); unshift @ret, $found . ' total missing ' . ( $found > 1 ? 'prerequisites:' : 'prerequisite:' ); unshift @ret, $blockOpen . $blockClose; unshift @ret, $tBOpen . $trOpen . $tdOpen; } else { my @hooray = ( 'hooray', 'hurray', 'phew', 'woop woop', 'woopee', 'wow', 'yay', 'yippie', ); my $x = 0 + int( rand( scalar @hooray + 1 - 0 ) ); unshift @ret, $tBOpen . $trOpen . $tdOpen . $lb . ucfirst( $hooray[$x] ) . '! All prerequisites are met.' . ( $html ? ' 🥳' : '' ) . $lb . $lb . $tdClose . $trClose . $tBClose; } push @ret, $tClose . $blockClose; unshift @ret, $blockOpen . $blockClose . ( $html ? '' : '' ) . $blockOpen . $tTitleOpen . ( $mode eq 'live' ? 'Live ' : '' ) . 'System Prerequisites Check' . $tTitleClose . $tOpen; return $header . join( "\n", @ret ) . $footer; } sub CreateSearchList ($$@) { my $hash = shift; my $getCmd = shift; my $search = join( '\s*', @_ ); $search = '.+' unless ($search); # disable automatic links to FHEM devices delete $FW_webArgs{addLinks}; my @ret; my $html = defined( $hash->{CL} ) && $hash->{CL}{TYPE} eq "FHEMWEB" ? 1 : 0; my $FW_CSRF = ( defined( $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} ) ? '&fwcsrf=' . $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} : '' ); my $FW_CSRF_input = defined( $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} ) ? '' : ''; my $header = ''; my $footer = ''; if ($html) { $header = ''; $footer = ''; } my $blockOpen = ''; my $tTitleOpen = ''; my $tTitleClose = ''; my $tOpen = ''; my $tCOpen = ''; my $tCClose = ''; my $tHOpen = ''; my $tHClose = ''; my $tBOpen = ''; my $tBClose = ''; my $tFOpen = ''; my $tFClose = ''; my $trOpen = ''; my $trOpenEven = ''; my $trOpenOdd = ''; my $thOpen = ''; my $thOpen2 = ''; my $thOpen3 = ''; my $tdOpen = ''; my $tdOpen2 = ''; my $tdOpen3 = ''; my $strongOpen = ''; my $strongClose = ''; my $tdClose = "\t\t\t"; my $thClose = "\t\t\t"; my $trClose = ''; my $tClose = ''; my $blockClose = ''; my $colorRed = ''; my $colorGreen = ''; my $colorClose = ''; if ($html) { $blockOpen = '
'; $tTitleOpen = ''; $tTitleClose = ''; $tOpen = ''; $tCOpen = ''; $tHOpen = ''; $tHClose = ''; $tBOpen = ''; $tBClose = ''; $tFOpen = ''; $tFClose = ''; $trOpen = ''; $trOpenEven = ''; $trOpenOdd = ''; $thOpen = ''; $thClose = ''; $trClose = ''; $tClose = '
'; $tCClose = '
'; $thOpen2 = ''; $thOpen3 = ''; $tdOpen = ''; $tdOpen2 = ''; $tdOpen3 = ''; $strongOpen = ''; $strongClose = ''; $tdClose = '
'; $blockClose = '
'; $colorRed = ''; $colorGreen = ''; $colorClose = ''; } my $space = $html ? ' ' : ' '; my $lb = $html ? '
' : "\n"; my $lang = lc( AttrVal( $hash->{NAME}, 'language', AttrVal( 'global', 'language', 'EN' ) ) ); # Add search input $header .= '
' . '
' . $FW_CSRF_input . '' . '' . '' . '
' . '' . '
'; my $found = 0; # search for matching device my $foundDevices = 0; my $linecount = 1; foreach my $device ( sort { "\L$a" cmp "\L$b" } keys %defs ) { next unless ( defined( $defs{$device}{TYPE} ) && !defined( $defs{$device}{TEMPORARY} ) && defined( $modules{ $defs{$device}{TYPE} } ) ); if ( $device =~ m/^.*$search.*$/i ) { unless ($foundDevices) { push @ret, ( $html ? '' : '' ) . $blockOpen . $tOpen . $tCOpen . 'Devices' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'Device Name' . $thClose; push @ret, $thOpen . 'Device Type' . $thClose; push @ret, $thOpen . 'Device State' . $thClose; push @ret, $trClose . $tHClose; } $found++; $foundDevices++; my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; FHEM::Meta::Load( $defs{$device}{TYPE} ); my $linkDev = $device; $linkDev = '' . $device . '' if ($html); my $linkMod = $defs{$device}{TYPE}; $linkMod = '' . $defs{$device}{TYPE} . '' if ($html); $l .= $tdOpen . $linkDev . $tdClose; $l .= $tdOpen . $linkMod . $tdClose; $l .= $tdOpen . ( defined( $defs{$device}{STATE} ) ? $defs{$device}{STATE} : '' ) . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tClose . $blockClose if ($foundDevices); # search for matching module my $foundModules = 0; $linecount = 1; foreach my $module ( sort { "\L$a" cmp "\L$b" } keys %modules ) { if ( $module =~ m/^.*$search.*$/i ) { unless ($foundModules) { push @ret, ( $html ? '' : '' ) . $blockOpen . $tOpen . $tCOpen . 'Modules' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'Module Name' . $thClose; push @ret, $thOpen . 'Abstract' . $thClose; push @ret, $trClose . $tHClose; } $found++; $foundModules++; my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; FHEM::Meta::Load($module); my $abstract = ''; $abstract = $modules{$module}{META}{abstract} if ( defined( $modules{$module}{META} ) && defined( $modules{$module}{META}{abstract} ) ); my $link = $module; $link = '' . $module . '' if ($html); $l .= $tdOpen . $link . $tdClose; $l .= $tdOpen . ( $abstract eq 'n/a' ? '' : $abstract ) . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tClose . $blockClose if ($foundModules); # search for matching module my $foundPackages = 0; $linecount = 1; foreach my $package ( sort { "\L$a" cmp "\L$b" } keys %packages ) { if ( $package =~ m/^.*$search.*$/i ) { unless ($foundPackages) { push @ret, ( $html ? '' : '' ) . $blockOpen . $tOpen . $tCOpen . 'Packages' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'Package Name' . $thClose; push @ret, $thOpen . 'Abstract' . $thClose; push @ret, $trClose . $tHClose; } $found++; $foundPackages++; my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; FHEM::Meta::Load($package); my $abstract = ''; $abstract = $packages{$package}{META}{abstract} if ( defined( $packages{$package}{META} ) && defined( $packages{$package}{META}{abstract} ) ); my $link = $package; $link = '' . $package . '' if ($html); $l .= $tdOpen . $link . $tdClose; $l .= $tdOpen . ( $abstract eq 'n/a' ? '' : $abstract ) . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tClose . $blockClose if ($foundPackages); # search for matching keyword my $foundKeywords = 0; $linecount = 1; foreach my $keyword ( sort { "\L$a" cmp "\L$b" } keys %FHEM::Meta::keywords ) { if ( $keyword =~ m/^.*$search.*$/i ) { push @ret, '' unless ($foundKeywords); $found++; $foundKeywords++; my $descr = FHEM::Meta::GetKeywordDesc( $keyword, $lang ); push @ret, $blockOpen . $tOpen; if ($html) { push @ret, '# ' . $keyword . $tCClose; } else { push @ret, '# ' . $keyword; } my @mAttrs = qw( modules packages ); push @ret, $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Type' . $thClose; push @ret, $thOpen . 'Abstract' . $thClose; push @ret, $trClose . $tHClose; foreach my $mAttr (@mAttrs) { next unless ( defined( $FHEM::Meta::keywords{$keyword}{$mAttr} ) && @{ $FHEM::Meta::keywords{$keyword}{$mAttr} } > 0 ); foreach my $item ( sort { "\L$a" cmp "\L$b" } @{ $FHEM::Meta::keywords{$keyword}{$mAttr} } ) { my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $type = $mAttr; $type = 'Module' if ( $mAttr eq 'modules' ); $type = 'Package' if ( $mAttr eq 'packages' ); FHEM::Meta::Load($item); my $abstract = ''; $abstract = $modules{$item}{META}{abstract} if ( defined( $modules{$item} ) && defined( $modules{$item}{META} ) && defined( $modules{$item}{META}{abstract} ) ); my $link = $item; $link = '' . $item . '' if ($html); $l .= $tdOpen . $link . $tdClose; $l .= $tdOpen . $type . $tdClose; $l .= $tdOpen . ( $abstract eq 'n/a' ? '' : $abstract ) . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tClose . $blockClose; } } # search for matching maintainer my $foundMaintainers = 0; $linecount = 1; foreach my $maintainer ( sort { "\L$a" cmp "\L$b" } keys %FHEM::Meta::maintainers ) { if ( $maintainer =~ m/^.*$search.*$/i ) { unless ($foundMaintainers) { push @ret, $blockOpen . $tOpen . $tCOpen . ( $html ? '' : '' ) . 'Authors & Maintainers' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Modules' . $thClose; push @ret, $thOpen . 'Packages' . $thClose; push @ret, $trClose . $tHClose; } $found++; $foundMaintainers++; my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $mods = ''; if ( defined( $FHEM::Meta::maintainers{$maintainer}{modules} ) ) { my $counter = 0; foreach my $mod ( sort { "\L$a" cmp "\L$b" } @{ $FHEM::Meta::maintainers{$maintainer}{modules} } ) { if ($html) { $mods .= '
' if ($counter); $mods .= '' . $mod . ''; } else { $mods .= "\n" unless ($counter); $mods .= $mod; } $counter++; } } my $pkgs = ''; if ( defined( $FHEM::Meta::maintainers{$maintainer}{packages} ) ) { my $counter = 0; foreach my $pkg ( sort { "\L$a" cmp "\L$b" } @{ $FHEM::Meta::maintainers{$maintainer}{packages} } ) { if ($html) { $pkgs .= '
' if ($counter); $pkgs .= '' . $pkg . ''; } else { $pkgs .= "\n" unless ($counter); $pkgs .= $pkg; } $counter++; } } $l .= $tdOpen . $maintainer . $tdClose; $l .= $tdOpen . $mods . $tdClose; $l .= $tdOpen . $pkgs . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tClose . $blockClose if ($foundMaintainers); # search for matching Perl package my $foundPerl = 0; $linecount = 1; foreach my $dependent ( sort { "\L$a" cmp "\L$b" } keys %{ $FHEM::Meta::dependents{pkgs} } ) { next if ( FHEM::Meta::ModuleIsPerlCore($dependent) ); next if ( FHEM::Meta::ModuleIsInternal($dependent) ); if ( $dependent =~ m/^.*$search.*$/i ) { unless ($foundPerl) { push @ret, $blockOpen . $tOpen . $tCOpen . ( $html ? '' : '' ) . 'Perl Packages' . $tCClose . $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Referenced from' . $thClose; push @ret, $trClose . $tHClose; } $found++; $foundPerl++; my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $references = ''; my $counter = 0; foreach my $pkgReq (qw(requires recommends suggests)) { next unless ( defined( $FHEM::Meta::dependents{pkgs}{$dependent}{$pkgReq} ) ); foreach my $mod ( sort { "\L$a" cmp "\L$b" } @{ $FHEM::Meta::dependents{pkgs}{$dependent}{$pkgReq} } ) { if ($html) { $references .= '
' if ($counter); $references .= '' . $mod . ''; } else { $references .= "\n" unless ($counter); $references .= $mod; } $counter++; } } $l .= $tdOpen . $dependent . $tdClose; $l .= $tdOpen . $references . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tClose . $blockClose if ($foundPerl); #TODO works only if fhem.pl patch was accepted: # https://forum.fhem.de/index.php/topic,98937.0.html if ( defined( $hash->{CL} ) && defined( $hash->{CL}{'.iDefCmdMethod'} ) && $hash->{CL}{'.iDefCmdMethod'} eq 'always' ) { my $cmdO = $hash->{CL}{'.iDefCmdOrigin'}; if ( defined( $cmds{$cmdO} ) && defined( $hash->{CL}{'.iDefCmdOverwrite'} ) && $hash->{CL}{'.iDefCmdOverwrite'} ) { my $cmd = $search; $cmd =~ s/^$cmdO//; $cmd = $cmdO . '!' . ( $cmd && $cmd ne '' ? ' ' . $cmd : '' ); unshift @ret, $lb . $lb . 'Did you mean to run command ' . $cmdO . ' instead?'; } delete $hash->{CL}{'.iDefCmdOrigin'}; delete $hash->{CL}{'.iDefCmdMethod'}; delete $hash->{CL}{'.iDefCmdOverwrite'}; } if ($found) { unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundPerl . ' ' . ( $foundPerl > 1 ? 'Perl packages' : 'Perl package' ) . ( $html ? '' : '' ) if ($foundPerl); unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundMaintainers . ' ' . ( $foundMaintainers > 1 ? 'authors' : 'author' ) . ( $html ? '' : '' ) if ($foundMaintainers); unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundKeywords . ' ' . ( $foundKeywords > 1 ? 'keywords' : 'keyword' ) . ( $html ? '' : '' ) if ($foundKeywords); unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundPackages . ' ' . ( $foundPackages > 1 ? 'packages' : 'package' ) . ( $html ? '' : '' ) if ($foundPackages); unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundModules . ' ' . ( $foundModules > 1 ? 'modules' : 'module' ) . ( $html ? '' : '' ) if ($foundModules); unshift @ret, $lb . $space . $space . ( $html ? '' : '' ) . $foundDevices . ' ' . ( $foundDevices > 1 ? 'devices' : 'device' ) . ( $html ? '' : '' ) if ($foundDevices); unshift @ret, $found . ' total search ' . ( $found > 1 ? 'results:' : 'result:' ); } else { unshift @ret, $tOpen . $trOpenOdd . $tdOpen . 'Nothing found' . $tdClose . $trClose . $tClose . $lb . $lb; } push @ret, $tdClose . $trClose . $tClose . $blockClose; unshift @ret, $blockOpen . $blockClose . ( $html ? '' : '' ) . $blockOpen . $tTitleOpen . 'Search Result' . $tTitleClose . $tOpen . $trOpen . $tdOpen . $blockOpen . $blockClose; return $header . join( "\n", @ret ) . $footer; } #TODO # - show master/slave dependencies # - show parent/child dependencies # - show other dependant/related modules # - fill empty keywords # - Get Community Support URL from MAINTAINERS.txt sub CreateMetadataList ($$$) { my ( $hash, $getCmd, $modName ) = @_; $modName = 'Global' if ( uc($modName) eq 'FHEM' ); my $modType = lc($getCmd) eq 'showmoduleinfo' ? 'module' : 'package'; # disable automatic links to FHEM devices delete $FW_webArgs{addLinks}; return 'Unknown module ' . $modName if ( $modType eq 'module' && !defined( $modules{$modName} ) ); FHEM::Meta::Load($modName); return 'Unknown package ' . $modName if ( $modType eq 'package' && !defined( $packages{$modName} ) ); return 'No metadata found about module ' . $modName if ( $modType eq 'module' && ( !defined( $modules{$modName}{META} ) || scalar keys %{ $modules{$modName}{META} } == 0 ) ); return 'No metadata found about package ' . $modName if ( $modType eq 'package' && ( !defined( $packages{$modName}{META} ) || scalar keys %{ $packages{$modName}{META} } == 0 ) ); my $modMeta = $modType eq 'module' ? $modules{$modName}{META} : $packages{$modName}{META}; my @ret; my $html = defined( $hash->{CL} ) && $hash->{CL}{TYPE} eq "FHEMWEB" ? 1 : 0; my $header = ''; my $footer = ''; if ($html) { $header = ''; $footer = ''; } my $blockOpen = ''; my $tTitleOpen = ''; my $tTitleClose = ''; my $tOpen = ''; my $tCOpen = ''; my $tCClose = ''; my $tHOpen = ''; my $tHClose = ''; my $tBOpen = ''; my $tBClose = ''; my $tFOpen = ''; my $tFClose = ''; my $trOpen = ''; my $trOpenEven = ''; my $trOpenOdd = ''; my $thOpen = ''; my $thOpen2 = ''; my $thOpen3 = ''; my $tdOpen = ''; my $tdOpen2 = ''; my $tdOpen3 = ''; my $tdOpen4 = ''; my $strongOpen = ''; my $strongClose = ''; my $tdClose = "\t\t\t"; my $thClose = "\t\t\t"; my $trClose = ''; my $tClose = ''; my $blockClose = ''; my $colorRed = ''; my $colorGreen = ''; my $colorClose = ''; if ($html) { $blockOpen = '
'; $tTitleOpen = ''; $tTitleClose = ''; $tOpen = ''; $tCOpen = ''; $tHOpen = ''; $tHClose = ''; $tBOpen = ''; $tBClose = ''; $tFOpen = ''; $tFClose = ''; $trOpen = ''; $trOpenEven = ''; $trOpenOdd = ''; $thOpen = ''; $thClose = ''; $trClose = ''; $tClose = '
'; $tCClose = '
'; $thOpen2 = ''; $thOpen3 = ''; $tdOpen = ''; $tdOpen2 = ''; $tdOpen3 = ''; $tdOpen4 = ''; $strongOpen = ''; $strongClose = ''; $tdClose = '
'; $blockClose = '
'; $colorRed = ''; $colorGreen = ''; $colorClose = ''; } my @mAttrs = qw( name abstract keywords version release_date release_status author copyright privacy homepage wiki command_reference community_support commercial_support bugtracker version_control license description ); my $space = $html ? ' ' : ' '; my $lb = $html ? '
' : "\n"; my $lang = lc( AttrVal( $hash->{NAME}, 'language', AttrVal( 'global', 'language', 'EN' ) ) ); my $FW_CSRF = ( defined( $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} ) ? '&fwcsrf=' . $defs{ $hash->{CL}{SNAME} }{CSRFTOKEN} : '' ); push @ret, $blockOpen . $tTitleOpen . ucfirst($modType) . ' Information' . $tTitleClose . $tOpen; my $linecount = 1; foreach my $mAttr (@mAttrs) { next if ( $mAttr eq 'release_status' && ( !defined( $modMeta->{release_status} ) || $modMeta->{release_status} eq 'stable' ) ); next if ( $mAttr eq 'abstract' && ( !defined( $modMeta->{abstract} ) || $modMeta->{abstract} eq 'n/a' || $modMeta->{abstract} eq '' ) ); next if ( $mAttr eq 'description' && ( !defined( $modMeta->{description} ) || $modMeta->{description} eq 'n/a' || $modMeta->{description} eq '' ) ); next if ( $mAttr eq 'bugtracker' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{bugtracker} ) ) ); next if ( $mAttr eq 'homepage' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{homepage} ) ) ); next if ( $mAttr eq 'copyright' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{x_copyright} ) ) ); next if ( $mAttr eq 'privacy' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{x_privacy} ) ) ); next if ( $mAttr eq 'wiki' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{x_wiki} ) ) ); next if ( $mAttr eq 'community_support' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{x_support_community} ) ) ); next if ( $mAttr eq 'commercial_support' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{x_support_commercial} ) ) ); next if ( $mAttr eq 'keywords' && ( !defined( $modMeta->{keywords} ) || !@{ $modMeta->{keywords} } ) ); next if ( $mAttr eq 'version' && ( !defined( $modMeta->{version} ) ) ); next if ( $mAttr eq 'version_control' && ( !defined( $modMeta->{resources} ) || !defined( $modMeta->{resources}{repository} ) ) ); next if ( $mAttr eq 'release_date' && ( !defined( $modMeta->{x_release_date} ) && !defined( $modMeta->{x_vcs} ) ) ); next if ( $mAttr eq 'command_reference' && $modType eq 'package' ); my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $mAttrName = $mAttr; $mAttrName =~ s/_/$space/g; $mAttrName =~ s/([\w'&]+)/\u\L$1/g; my $webname = AttrVal( $hash->{CL}{SNAME}, 'webname', 'fhem' ); $l .= $thOpen . $mAttrName . $thClose; # these attributes do not exist under that name in META.json if ( !defined( $modMeta->{$mAttr} ) ) { $l .= $tdOpen; if ( $mAttr eq 'release_date' ) { if ( defined( $modMeta->{x_release_date} ) ) { $l .= $modMeta->{x_release_date}; } elsif ( defined( $modMeta->{x_vcs} ) ) { $l .= $modMeta->{x_vcs}[7]; } } elsif ( $mAttr eq 'copyright' ) { my $copyName = '© '; my $copyEmail = defined( $modMeta->{resources}{x_copyright}{mailto} ) ? $modMeta->{resources}{x_copyright}{mailto} : ''; my $copyWeb; my $copyNameContact; $copyName .= $modMeta->{x_vcs}[8] . ' ' if ( defined( $modMeta->{x_vcs} ) ); $copyName .= $modMeta->{resources}{x_copyright}{title}; if ( defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{x_copyright} ) && defined( $modMeta->{resources}{x_copyright}{web} ) ) { $copyWeb = $modMeta->{resources}{x_copyright}{web}; } if ( $html && $copyWeb ) { $copyNameContact = '' . $copyName . ''; } elsif ( $html && $copyEmail ) { $copyNameContact = '' . $copyName . ''; } $l .= $copyNameContact ? $copyNameContact : $copyName; } elsif ( $mAttr eq 'privacy' ) { my $title = defined( $modMeta->{resources}{x_privacy}{title} ) ? $modMeta->{resources}{x_privacy}{title} : $modMeta->{resources}{x_privacy}{web}; $l .= '' . $title . ''; } elsif ($mAttr eq 'homepage' && defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{homepage} ) ) { my $title = defined( $modMeta->{resources}{x_homepage_title} ) ? $modMeta->{resources}{x_homepage_title} : ( $modMeta->{resources}{homepage} =~ m/^.+:\/\/([^\/]+).*/ ? $1 : $modMeta->{resources}{homepage} ); $l .= '' . $title . ''; } elsif ( $mAttr eq 'command_reference' ) { if ( defined( $hash->{CL} ) && defined( $hash->{CL}{TYPE} ) && $hash->{CL}{TYPE} eq 'FHEMWEB' ) { $l .= 'Offline version'; } if ( defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{x_commandref} ) && defined( $modMeta->{resources}{x_commandref}{web} ) ) { my $title = defined( $modMeta->{resources}{x_commandref}{title} ) ? $modMeta->{resources}{x_commandref}{title} : 'Online version'; $l .= ( $webname ? ' | ' : '' ) . '' . $title . ''; } } elsif ($mAttr eq 'wiki' && defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{x_wiki} ) && defined( $modMeta->{resources}{x_wiki}{web} ) ) { my $title = defined( $modMeta->{resources}{x_wiki}{title} ) ? $modMeta->{resources}{x_wiki}{title} : ( $modMeta->{resources}{x_wiki}{web} =~ m/^(?:https?:\/\/)?wiki\.fhem\.de/i ? 'FHEM Wiki' : '' ); $title = 'FHEM Wiki: ' . $title if ( $title ne '' && $title !~ m/^FHEM Wiki/i && $modMeta->{resources}{x_wiki}{web} =~ m/^(?:https?:\/\/)?wiki\.fhem\.de/i ); $l .= '' . $title . ''; } elsif ($mAttr eq 'community_support' && defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{x_support_community} ) && defined( $modMeta->{resources}{x_support_community}{web} ) ) { my $board = $modMeta->{resources}{x_support_community}; $board = $modMeta->{resources}{x_support_community}{subCommunity} if ( defined( $modMeta->{resources}{x_support_community}{subCommunity} ) ); my $title = defined( $board->{title} ) ? $board->{title} : ( $board->{web} =~ m/^(?:https?:\/\/)?forum\.fhem\.de/i ? 'FHEM Forum' : '' ); $title = 'FHEM Forum: ' . $title if ( $title ne '' && $title !~ m/^FHEM Forum/i && $board->{web} =~ m/^(?:https?:\/\/)?forum\.fhem\.de/i ); $l .= 'Limited - ' if ( defined( $modMeta->{x_support_status} ) && $modMeta->{x_support_status} eq 'limited' ); $l .= '{description} ) ? ' title="' . $board->{description} . '"' : ( defined( $modMeta->{resources}{x_support_community} {description} ) ? ' title="' . $modMeta->{resources}{x_support_community} {description} . '"' : '' ) ) . '>' . $title . ''; } elsif ($mAttr eq 'commercial_support' && defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{x_support_commercial} ) && defined( $modMeta->{resources}{x_support_commercial}{web} ) ) { my $title = defined( $modMeta->{resources}{x_support_commercial}{title} ) ? $modMeta->{resources}{x_support_commercial}{title} : $modMeta->{resources}{x_support_commercial}{web}; $l .= 'Limited - ' if ( $modMeta->{x_support_status} eq 'limited' ); $l .= '' . $title . ''; } elsif ($mAttr eq 'bugtracker' && defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{bugtracker} ) && defined( $modMeta->{resources}{bugtracker}{web} ) ) { my $title = defined( $modMeta->{resources}{bugtracker}{x_web_title} ) ? $modMeta->{resources}{bugtracker}{x_web_title} : ( $modMeta->{resources}{bugtracker}{web} =~ m/^(?:https?:\/\/)?forum\.fhem\.de/i ? 'FHEM Forum' : ( $modMeta->{resources}{bugtracker}{web} =~ m/^(?:https?:\/\/)?github\.com\/fhem/i ? 'Github Issues: ' . $modMeta->{name} : $modMeta->{resources}{bugtracker}{web} ) ); # add prefix if user defined title $title = 'FHEM Forum: ' . $title if ( $title ne '' && $title !~ m/^FHEM Forum/i && $modMeta->{resources}{bugtracker}{web} =~ m/^(?:https?:\/\/)?forum\.fhem\.de/i ); $title = 'Github Issues: ' . $title if ( $title ne '' && $title !~ m/^Github issues/i && $modMeta->{resources}{bugtracker}{web} =~ m/^(?:https?:\/\/)?github\.com\/fhem/i ); $l .= '' . $title . ''; } elsif ($mAttr eq 'version_control' && defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{repository} ) && defined( $modMeta->{resources}{repository}{type} ) && defined( $modMeta->{resources}{repository}{url} ) ) { # Web link if ( defined( $modMeta->{resources}{repository}{web} ) ) { # master link my $url = $modMeta->{resources}{repository}{web}; if ( defined( $modMeta->{resources}{repository}{x_branch} ) && defined( $modMeta->{resources}{repository}{x_dev} ) && defined( $modMeta->{resources}{repository}{x_dev}{x_branch} ) ) { my $bName = $modMeta->{resources}{repository}{x_branch}; $bName = 'production' if ( $modMeta->{resources}{repository}{x_branch} eq $modMeta->{resources}{repository}{x_dev}{x_branch} ); # webview: master entry $l .= 'View online source code: ' . $bName . ''; # webview: dev link $bName = $modMeta->{resources}{repository}{x_dev}{x_branch}; $bName = 'development' if ( $modMeta->{resources}{repository}{x_branch} eq $modMeta->{resources}{repository}{x_dev}{x_branch} ); $url = $modMeta->{resources}{repository}{x_dev}{web}; # webview: dev entry $l .= ' | ' . $bName . ''; # raw: master entry if ( defined( $modMeta->{resources}{repository}{x_raw} ) ) { $bName = $modMeta->{resources}{repository}{x_branch}; $bName = 'production' if ( $modMeta->{resources}{repository}{x_branch} eq $modMeta->{resources}{repository}{x_dev} {x_branch} ); $url = $modMeta->{resources}{repository}{x_raw}; $l .= $lb . 'Download raw file: ' . $bName . ''; # raw: dev link if ( defined( $modMeta->{resources}{repository}{x_dev} {x_raw} ) ) { $bName = $modMeta->{resources}{repository}{x_dev} {x_branch}; $bName = 'development' if ( $modMeta->{resources}{repository}{x_branch} eq $modMeta->{resources}{repository}{x_dev} {x_branch} ); $url = $modMeta->{resources}{repository}{x_dev} {x_raw}; # raw: dev entry $l .= ' | ' . $bName . ''; } } } # master entry else { $l .= 'View online source code'; if ( defined( $modMeta->{resources}{repository}{x_raw} ) ) { $l .= $lb . 'Download raw file'; } } $l .= $lb; } # VCS link my $urlPrefix = ( $modMeta->{resources}{repository}{url} =~ /^$modMeta->{resources}{repository}{type}/i ? '' : lc( $modMeta->{resources}{repository}{type} ) . '+' ); $l .= uc( $modMeta->{resources}{repository}{type} ) . ' repository: ' . '' . $urlPrefix . $modMeta->{resources}{repository}{url} . ''; if ( defined( $modMeta->{resources}{repository}{x_branch} ) ) { if ( lc( $modMeta->{resources}{repository}{type} ) eq 'svn' ) { $l .= $lb . 'Main branch: ' . '' . $modMeta->{resources}{repository}{x_branch} . ''; } else { $l .= $lb . 'Main branch: ' . $modMeta->{resources}{repository}{x_branch}; } } if ( defined( $modMeta->{resources}{repository}{x_branch} ) && defined( $modMeta->{resources}{repository}{x_dev} ) && defined( $modMeta->{resources}{repository}{x_dev}{x_branch} ) && $modMeta->{resources}{repository}{x_branch} ne $modMeta->{resources}{repository}{x_dev}{x_branch} ) { if ( lc( $modMeta->{resources}{repository}{x_dev}{type} ) eq 'svn' ) { $l .= $lb . 'Dev branch: ' . '' . $modMeta->{resources}{repository}{x_dev}{x_branch} . ''; } else { $l .= $lb . 'Dev branch: ' . $modMeta->{resources}{repository}{x_dev}{x_branch}; } } } else { $l .= '-'; } $l .= $tdClose; } # these text attributes can be shown directly elsif ( !ref( $modMeta->{$mAttr} ) ) { $l .= $tdOpen; my $mAttrVal = defined( $modMeta->{x_lang} ) && defined( $modMeta->{x_lang}{$lang} ) && defined( $modMeta->{x_lang}{$lang}{$mAttr} ) ? $modMeta->{x_lang}{$lang}{$mAttr} : $modMeta->{$mAttr}; $mAttrVal =~ s/\\n/$lb/g; if ( $mAttr eq 'version' ) { if ( $mAttrVal eq '0.000000001' ) { $mAttrVal = '-'; } elsif ( $modMeta->{x_file}[7] ne 'generated/vcs' ) { $mAttrVal = version->parse($mAttrVal)->normal; # only show maximum featurelevel for fhem.pl $mAttrVal = $1 if ( $modName eq 'Global' && $mAttrVal =~ m/^(v\d+\.\d+).*/ ); # Only add commit revision when it is not # part of the version already $mAttrVal .= '-s' . $modMeta->{x_vcs}[5] if ( defined( $modMeta->{x_vcs} ) && $modMeta->{x_vcs}[5] ne '' ); } } # Add filename to module name $mAttrVal .= ' (' . $modMeta->{x_file}[2] . ')' if ( $modType eq 'module' && $mAttr eq 'name' && $modName ne 'Global' ); $l .= $mAttrVal . $tdClose; } # this attribute is an array and needs further processing elsif (ref( $modMeta->{$mAttr} ) eq 'ARRAY' && @{ $modMeta->{$mAttr} } > 0 && $modMeta->{$mAttr}[0] ne '' ) { $l .= $tdOpen; if ( $mAttr eq 'license' ) { if ( defined( $modMeta->{resources} ) && defined( $modMeta->{resources}{license} ) && ref( $modMeta->{resources}{license} ) eq 'ARRAY' && @{ $modMeta->{resources}{license} } > 0 && $modMeta->{resources}{license}[0] ne '' ) { $l .= '' . $modMeta->{$mAttr}[0] . ''; } else { $l .= $modMeta->{$mAttr}[0]; } } elsif ( $mAttr eq 'author' ) { my $authorCount = scalar @{ $modMeta->{$mAttr} }; my $counter = 0; foreach ( @{ $modMeta->{$mAttr} } ) { next if ( $_ eq '' ); my $authorName; my $authorEditorOnly; my $authorEmail; if ( $_ =~ m/^([^<>\n\r]+?)(?:\s+(\(last release only\)))?(?:\s+(?:<(.*)>))?$/ ) { $authorName = $1; $authorEditorOnly = $2 ? ' ' . $2 : ''; $authorEmail = $3; } my $authorNameEmail = $authorName; # add alias name if different if ( defined( $modMeta->{x_fhem_maintainer} ) && ref( $modMeta->{x_fhem_maintainer} ) eq 'ARRAY' && @{ $modMeta->{x_fhem_maintainer} } > 0 && $modMeta->{x_fhem_maintainer}[$counter] ne '' ) { my $alias = $modMeta->{x_fhem_maintainer}[$counter]; if ( $alias eq $authorName ) { $authorNameEmail = '' . $authorName . '' . $authorEditorOnly if ($html); } else { if ($html) { $authorNameEmail = $authorName . ', alias ' . $alias . '' . $authorEditorOnly; } else { $authorNameEmail = $authorName . $authorEditorOnly . ', alias ' . $alias; } } } $l .= $lb if ($counter); $l .= $lb . 'Co-' . $mAttrName . ':' . $lb if ( $counter == 1 ); $l .= $authorNameEmail ? $authorNameEmail : $authorName . $authorEditorOnly; $counter++; } } elsif ( $mAttr eq 'keywords' ) { my $counter = 0; foreach my $keyword ( @{ $modMeta->{$mAttr} } ) { $l .= ', ' if ($counter); my $descr = FHEM::Meta::GetKeywordDesc( $keyword, $lang ); if ($html) { $l .= '' . $keyword . ''; } else { $l .= $keyword; } $counter++; } } else { $l .= join ', ', @{ $modMeta->{$mAttr} }; } $l .= $tdClose; } # woops, we don't know how to handle this attribute else { $l .= $tdOpen . '?' . $tdClose; } $l .= $trClose; push @ret, $l; $linecount++; } push @ret, $tFOpen . $trOpen . ( $html ? '' : '' ) . 'Based on data generated by ' . $lb . $modMeta->{generated_by} . $tdClose . $trClose . $tFClose; push @ret, $tClose . $blockClose; # show FHEM modules who use this package @mAttrs = qw( requires recommends suggests ); $linecount = 1; foreach my $mAttr (@mAttrs) { next unless ( defined( $FHEM::Meta::dependents{pkgs}{$modName}{$mAttr} ) && ref( $FHEM::Meta::dependents{pkgs}{$modName}{$mAttr} ) eq 'ARRAY' && @{ $FHEM::Meta::dependents{pkgs}{$modName}{$mAttr} } > 0 ); my $dependents = ''; my $counter = 0; foreach my $dependant ( sort { "\L$a" cmp "\L$b" } @{ $FHEM::Meta::dependents{pkgs}{$modName}{$mAttr} } ) { my $link = $dependant; $link = '' . $dependant . '' if ($html); $dependents .= ', ' if ($counter); $dependents .= $link; $counter++; } if ( $dependents ne '' ) { if ( $linecount == 1 ) { push @ret, $blockOpen . $tTitleOpen . 'FHEM internal dependencies' . $tTitleClose . $tOpen; push @ret, $tHOpen . $trOpen; push @ret, $thOpen . 'Importance' . $thClose; push @ret, $thOpen . 'Dependent Modules' . $thClose; push @ret, $trClose . $tHClose; } my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $importance = $mAttr; $importance = 'required' if ( $mAttr eq 'requires' ); $importance = 'recommended' if ( $mAttr eq 'recommends' ); $importance = 'suggested' if ( $mAttr eq 'suggests' ); $l .= $tdOpen . $importance . $tdClose; $l .= $tdOpen . $dependents . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tFOpen . $trOpen . $tdOpen2 . $strongOpen . 'Hint:' . $strongClose . ' Dependents can only be shown here if they were loaded into the metadata cache before.' . $tdClose . $trClose . $tFClose . $tClose . $blockClose if ( $linecount > 1 ); if ( $modType eq 'module' && $modName ne 'Global' && ( !defined( $modules{$modName}{META} ) || !defined( $modules{$modName}{META}{keywords} ) || ! grep ( /^fhem-mod-command$/, @{ $modules{$modName}{META}{keywords} } ) ) ) { push @ret, $blockOpen . $tTitleOpen . 'Devices' . $tTitleClose . $tOpen; my $linecount = 1; if ( defined( $modules{$modName}{LOADED} ) && $modules{$modName}{LOADED} ) { my @instances = devspec2array( 'TYPE=' . $modName ); if ( @instances > 0 ) { push @ret, $tHOpen . $trOpen . $thOpen . 'Name' . $thClose . $thOpen . 'State' . $thClose . $trClose . $tHClose . $tBOpen; foreach my $instance ( sort { "\L$a" cmp "\L$b" } @instances ) { next if ( defined( $defs{$instance}{TEMPORARY} ) ); my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $device = $instance; $device = '' . $instance . '' if ($html); $l .= $tdOpen . $device . $tdClose; $l .= $tdOpen . $defs{$instance}{STATE} . $tdClose; push @ret, $l; $linecount++; } push @ret, $tBClose; } else { push @ret, $tBOpen . $trOpen . $tdOpen . 'The module was once loaded into memory, ' . 'but currently there is no device defined.' . $tdClose . $trClose . $tBClose; } } else { push @ret, $tBOpen . $trOpen . $tdOpen . 'The module is currently not in use.' . $tdClose . $trClose . $tBClose; } push @ret, $tClose . $blockClose; } LoadInstallStatusPerl($modName); push @ret, $blockOpen . $tTitleOpen . 'System Prerequisites' . $tTitleClose . $tOpen . $trOpen . $tdOpen; push @ret, $blockOpen . $tOpen . $tCOpen . 'Perl Packages' . $tCClose; if ( defined( $modMeta->{prereqs} ) && defined( $modMeta->{prereqs}{runtime} ) ) { @mAttrs = qw( requires recommends suggests ); push @ret, $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Importance' . $thClose; push @ret, $thOpen . 'Status' . $thClose; push @ret, $thOpen . 'Action' . $thClose if ($html); push @ret, $trClose . $tHClose . $tBOpen; $linecount = 1; foreach my $mAttr (@mAttrs) { next unless ( defined( $modMeta->{prereqs}{runtime}{$mAttr} ) && keys %{ $modMeta->{prereqs}{runtime}{$mAttr} } > 0 ); foreach my $prereq ( sort keys %{ $modMeta->{prereqs}{runtime}{$mAttr} } ) { my $isFhem = FHEM::Meta::ModuleIsInternal($prereq); my $installed = $pkgStatus{Perl}{pkgs}{$prereq}{status}; my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $importance = $mAttr; $importance = 'required' if ( $mAttr eq 'requires' ); $importance = 'recommended' if ( $mAttr eq 'recommends' ); $importance = 'suggested' if ( $mAttr eq 'suggests' ); my $version = $modMeta->{prereqs}{runtime}{$mAttr}{$prereq}; $version = '' if ( !defined($version) || $version eq '0' ); my $action = ''; my $inherited = ''; if ( defined( $modMeta->{prereqs}{runtime}{x_inherited} ) && defined( $modMeta->{prereqs}{runtime}{x_inherited}{$prereq} ) ) { $inherited = '[inherited]'; $inherited = '' . $inherited . '' if ($html); } if ( $mAttr ne 'requires' && ( $installed eq 'missing' || $installed eq 'outdated' ) ) { $installed = ''; $action = ''; } elsif ( $installed eq 'installed' ) { $installed = $colorGreen . $installed . $colorClose; } elsif ($installed eq 'missing' || $installed eq 'outdated' ) { $installed = $colorRed . $strongOpen . uc($installed) . $strongClose . $colorClose; $action = ''; } $prereq = '' . $prereq . '' if ( $html && $installed ne 'built-in' && $installed ne 'included' ); $prereq = '' . $prereq . '' if ( $html && $installed eq 'included' ); $l .= $tdOpen . $prereq . ( $inherited ne '' ? " $inherited" : '' ) . ( $version ne '' ? " ($version)" : '' ) . $tdClose; $l .= $tdOpen . $importance . $tdClose; $l .= $tdOpen . $installed . $tdClose; $l .= $tdOpen . $action . $tdClose if ($html); $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tBClose; push @ret, $tFOpen . $trOpenEven . ( $html ? $tdOpen4 : $tdOpen3 ) . $strongOpen . 'Hint:' . $strongClose . ' The module does not provide Perl prerequisites from its metadata.' . $lb . 'This result is based on automatic source code analysis ' . 'and can be incorrect. ' . 'Suggested Perl items may still be required if the module author had decided to implement some own dependency and/or error handling like returning an informative message instead of the original Perl error message.' . $tdClose . $trClose . $tFClose if ( defined( $modMeta->{x_prereqs_src} ) && $modMeta->{x_prereqs_src} ne 'META.json' ); } elsif ( defined( $modMeta->{x_prereqs_src} ) ) { push @ret, $tBOpen . $trOpenOdd . $tdOpen . 'No known prerequisites.' . $tdClose . $trClose . $tBClose; } else { push @ret, $tBOpen . $trOpenOdd . $tdOpen . 'Module metadata do not contain any prerequisites.' . "\n" . ( $html ? 'Click here to install Perl::PrereqScanner::NotQuiteLite for automatic source code analysis.' : 'For automatic source code analysis, please install Perl::PrereqScanner::NotQuiteLite first.' ) . $tdClose . $trClose . $tBClose; } push @ret, $tClose . $blockClose; if ( defined( $modMeta->{x_prereqs_nodejs} ) && defined( $modMeta->{x_prereqs_nodejs}{runtime} ) ) { push @ret, $blockOpen . $tTitleClose . $tOpen . $tCOpen . 'Node.js Packages' . $tCClose; my @mAttrs = qw( requires recommends suggests ); push @ret, $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Importance' . $thClose; push @ret, $thOpen . 'Status' . $thClose; push @ret, $trClose . $tHClose . $tBOpen; $linecount = 1; foreach my $mAttr (@mAttrs) { next unless ( defined( $modMeta->{x_prereqs_nodejs}{runtime}{$mAttr} ) && keys %{ $modMeta->{x_prereqs_nodejs}{runtime}{$mAttr} } > 0 ); foreach my $prereq ( sort keys %{ $modMeta->{x_prereqs_nodejs}{runtime}{$mAttr} } ) { my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $importance = $mAttr; $importance = 'required' if ( $mAttr eq 'requires' ); $importance = 'recommended' if ( $mAttr eq 'recommends' ); $importance = 'suggested' if ( $mAttr eq 'suggests' ); my $version = $modMeta->{x_prereqs_nodejs}{runtime}{$mAttr}{$prereq}; $version = '' if ( !defined($version) || $version eq '0' ); my $check = __IsInstalledNodejs($prereq); my $installed = ''; if ($check) { if ( $check =~ m/^\d+\./ ) { my $nverReq = $version ne '' ? $version : 0; my $nverInst = $check; #TODO suport for version range: #https://metacpan.org/pod/CPAN::Meta::Spec#Version-Range if ( $nverReq > 0 && $nverInst < $nverReq ) { $installed .= $colorRed . 'OUTDATED' . $colorClose . ' (' . $check . ')'; } else { $installed = 'installed'; } } else { $installed = 'installed'; } } else { $installed = $colorRed . 'MISSING' . $colorClose if ( $importance eq 'required' ); } $installed = $colorGreen . $installed . $colorClose; $prereq = '' . $prereq . '' if ($html); $l .= $tdOpen . $prereq . ( $version ne '' ? " ($version)" : '' ) . $tdClose; $l .= $tdOpen . $importance . $tdClose; $l .= $tdOpen . $installed . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tBClose . $tClose . $blockClose; } if ( defined( $modMeta->{x_prereqs_python} ) && defined( $modMeta->{x_prereqs_python}{runtime} ) ) { push @ret, $blockOpen . $tOpen . $tCOpen . 'Python Packages' . $tCClose; my @mAttrs = qw( requires recommends suggests ); push @ret, $tHOpen . $trOpen; push @ret, $thOpen . 'Name' . $thClose; push @ret, $thOpen . 'Importance' . $thClose; push @ret, $thOpen . 'Status' . $thClose; push @ret, $trClose . $tHClose . $tBOpen; $linecount = 1; foreach my $mAttr (@mAttrs) { next unless ( defined( $modMeta->{x_prereqs_python}{runtime}{$mAttr} ) && keys %{ $modMeta->{x_prereqs_python}{runtime}{$mAttr} } > 0 ); foreach my $prereq ( sort keys %{ $modMeta->{x_prereqs_python}{runtime}{$mAttr} } ) { my $l = $linecount % 2 == 0 ? $trOpenEven : $trOpenOdd; my $importance = $mAttr; $importance = 'required' if ( $mAttr eq 'requires' ); $importance = 'recommended' if ( $mAttr eq 'recommends' ); $importance = 'suggested' if ( $mAttr eq 'suggests' ); my $version = $modMeta->{x_prereqs_python}{runtime}{$mAttr}{$prereq}; $version = '' if ( !defined($version) || $version eq '0' ); my $check = __IsInstalledPython($prereq); my $installed = ''; if ($check) { if ( $check =~ m/^\d+\./ ) { my $nverReq = $version ne '' ? $version : 0; my $nverInst = $check; #TODO suport for version range: #https://metacpan.org/pod/CPAN::Meta::Spec#Version-Range if ( $nverReq > 0 && $nverInst < $nverReq ) { $installed .= $colorRed . 'OUTDATED' . $colorClose . ' (' . $check . ')'; } else { $installed = 'installed'; } } else { $installed = 'installed'; } } else { $installed = $colorRed . 'MISSING' . $colorClose if ( $importance eq 'required' ); } my $isPerlCore = FHEM::Meta::ModuleIsPerlCore($prereq); my $isFhem = $isPerlCore ? 0 : FHEM::Meta::ModuleIsInternal($prereq); if ( $isPerlCore || $prereq eq 'perl' ) { $installed = $installed ne 'installed' ? "$installed (Perl built-in)" : 'built-in'; } elsif ($isFhem) { $installed = $installed ne 'installed' ? "$installed (FHEM included)" : 'included'; } elsif ( $installed eq 'installed' ) { $installed = $colorGreen . $installed . $colorClose; } $prereq = '' . $prereq . '' if ( $html && !$isFhem && !$isPerlCore && $prereq ne 'perl' ); $l .= $tdOpen . $prereq . ( $version ne '' ? " ($version)" : '' ) . $tdClose; $l .= $tdOpen . $importance . $tdClose; $l .= $tdOpen . $installed . $tdClose; $l .= $trClose; push @ret, $l; $linecount++; } } push @ret, $tBClose . $tClose . $blockClose; } push @ret, $tdClose . $trClose . $tClose . $blockClose; return $header . join( "\n", @ret ) . $footer; } sub CreateRawMetaJson ($$$) { my ( $hash, $getCmd, $modName ) = @_; $modName = 'Global' if ( uc($modName) eq 'FHEM' ); my $modType = lc($getCmd) eq 'zzgetmodulemeta.json' ? 'module' : 'package'; FHEM::Meta::Load($modName); return '{}' unless ( ( $modType eq 'module' && defined( $modules{$modName}{META} ) && scalar keys %{ $modules{$modName}{META} } > 0 ) || ( $modType eq 'package' && defined( $packages{$modName}{META} ) && scalar keys %{ $packages{$modName}{META} } > 0 ) ); my $j = JSON->new; $j->allow_nonref; $j->canonical; $j->pretty; if ( $modType eq 'module' ) { return $j->encode( $modules{$modName}{META} ); } else { return $j->encode( $packages{$modName}{META} ); } } sub __GetDefinedModulesFromFile($) { my ($filePath) = @_; my @modules; my $fh; if ( open( $fh, '<' . $filePath ) ) { while ( my $l = <$fh> ) { if ( $l =~ /^define\s+\S+\s+(\S+).*/ ) { my $modName = $1; push @modules, $modName unless ( grep ( /^$modName$/, @modules ) ); } } close($fh); } if (wantarray) { return @modules; } elsif ( @modules > 0 ) { return join( ',', @modules ); } } sub LoadInstallStatusPerl(;$) { my ($modList) = @_; my $t = TimeNow(); my @rets; my $unused = 0; my @lmodules; # if modList is undefined or is equal to '1' if ( !$modList || ( !ref($modList) && $modList eq '1' ) ) { $unused = 1 if ( $modList && $modList eq '1' ); foreach ( keys %modules ) { # Only process loaded modules # unless unused modules were # explicitly requested push @lmodules, $_ if ( $unused || ( defined( $modules{$_}{LOADED} ) && $modules{$_}{LOADED} eq '1' ) ); } } # if a single module name was given elsif ( !ref($modList) ) { push @lmodules, $modList; } # if a list of module names was given elsif ( ref($modList) eq 'ARRAY' ) { foreach ( @{$modList} ) { push @lmodules, $_; } } # if a hash was given, assume every # key is a module name elsif ( ref($modList) eq 'HASH' ) { foreach ( keys %{$modList} ) { push @lmodules, $_; } } # Wrong method use else { $@ = __PACKAGE__ . "LoadInstallStatusPerl: ERROR: Unknown parameter value"; Log 1, $@; return "$@"; } foreach my $modName (@lmodules) { $modName = 'Global' if ( uc($modName) eq 'FHEM' ); my $type; if ( exists( $modules{$modName} ) && !exists( $packages{$modName} ) ) { $type = 'module'; } elsif ( exists( $packages{$modName} ) && !exists( $modules{$modName} ) ) { $type = 'package'; } elsif (exists( $packages{$modName} ) && exists( $modules{$modName} ) ) { $type = 'module+package'; } next unless ($type); foreach my $type ( split( '\+', $type ) ) { FHEM::Meta::Load($modName); next unless ( ( $type eq 'module' && defined( $modules{$modName}{META} ) ) || ( $type eq 'package' && defined( $packages{$modName}{META} ) ) ); my $modMeta = $type eq 'module' ? $modules{$modName}{META} : $packages{$modName}{META}; $pkgStatus{Perl}{analyzed} = 2 unless ( defined( $modMeta->{x_prereqs_src} ) ); # Perl if ( defined( $modMeta->{prereqs} ) && defined( $modMeta->{prereqs}{runtime} ) ) { my $modPreqs = $modMeta->{prereqs}{runtime}; foreach my $mAttr (qw(requires recommends suggests)) { next unless ( defined( $modPreqs->{$mAttr} ) && keys %{ $modPreqs->{$mAttr} } > 0 ); foreach my $pkg ( keys %{ $modPreqs->{$mAttr} } ) { push @{ $pkgStatus{Perl}{pkgs}{$pkg}{ $type . 's' }{$mAttr} }, $modName unless ( grep ( /^$modName$/, @{ $pkgStatus{Perl}{pkgs}{$pkg} { $type . 's' }{$mAttr} } ) ); next if ( defined( $pkgStatus{Perl}{pkgs}{$pkg}{status} ) ); my $fname = $pkg; $fname =~ s/^.*://g; # strip away any parent module names my $isPerlCore = FHEM::Meta::ModuleIsPerlCore($pkg); my $isFhem = $isPerlCore ? 0 : FHEM::Meta::ModuleIsInternal($pkg); if ( $pkg eq 'perl' ) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'built-in'; $pkgStatus{Perl}{installed}{$pkg} = version->parse($])->numify; } elsif ( $pkg eq 'FHEM' ) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'included'; $pkgStatus{Perl}{installed}{$pkg} = $modules{'Global'}{META}{version}; } elsif ( $pkg eq 'FHEM::Meta' || $pkg eq 'Meta' ) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'included'; $pkgStatus{Perl}{installed}{$pkg} = FHEM::Meta->VERSION(); } elsif ($isPerlCore) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'built-in'; $pkgStatus{Perl}{installed}{$pkg} = 0; } # This is a FHEM package elsif ( $isFhem && $isFhem eq 'package' ) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'included'; $pkgStatus{Perl}{installed}{$pkg} = defined( $packages{$fname}{META} ) ? $packages{$fname}{META}{version} : 0; } # This is a FHEM module being loaded as package elsif ( $isFhem && $isFhem eq 'module' ) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'included'; $pkgStatus{Perl}{installed}{$pkg} = defined( $modules{$fname}{META} ) ? $modules{$fname}{META}{version} : 0; } elsif ( $pkg =~ /^Win32::/ && $^O !~ /Win/ ) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'n/a'; } else { my $pkgpath = $pkg . '.pm'; $pkgpath =~ s/::/\//g; # remove any ealier tries to load # to get the original error message foreach ( keys %INC ) { delete $INC{$_} if ( !$INC{$_} ); } #FIXME disable warnings does not work here... no warnings; my $verbose = AttrVal( 'global', 'verbose', 3 ); $attr{global}{verbose} = 0; eval "no warnings; require $pkg;"; $attr{global}{verbose} = $verbose; use warnings; if ( $@ && $@ =~ m/^Can't locate (\S+)\.pm/i ) { my $missing = $1; $missing =~ s/\//::/g; $pkgStatus{Perl}{pkgs}{$missing}{status} = 'missing'; push @{ $pkgStatus{Perl}{missing}{$missing} }, defined( $modPreqs->{$mAttr}{$missing} ) ? $modPreqs->{$mAttr}{$missing} : 0; $pkgStatus{Perl}{analyzed} = 1 if ( $modMeta->{x_prereqs_src} ne 'META.json' && !$pkgStatus{Perl}{analyzed} ); # If the error message does contain a # different package name, # the actual package is installed and # misses another package by it's own if ( $missing ne $pkg ) { my $v = eval "$pkg->VERSION()"; $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'installed'; $pkgStatus{Perl}{installed}{$pkg} = $v ? $v : 0; push @{ $pkgStatus{Perl}{pkgs}{$missing} { $type . 's' }{$mAttr} }, $modName unless ( grep ( /^$modName$/, @{ $pkgStatus{Perl}{pkgs}{$missing} { $type . 's' }{$mAttr} } ) ); # Lets also update the module meta data if ( $type eq 'module' ) { $modMeta->{prereqs} {runtime}{$mAttr}{$missing} = 0; push @{ $modMeta->{prereqs}{runtime} {x_inherited}{$missing} }, $pkg; } else { $packages{$modName}{META}{prereqs} {runtime}{$mAttr}{$missing} = 0; push @{ $packages{$modName}{META}{prereqs} {runtime}{x_inherited}{$missing} }, $pkg; } } } else { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'installed'; my $v = eval "$pkg->VERSION()"; $pkgStatus{Perl}{installed}{$pkg} = $v ? $v : 0; } } # check for outdated version if ( $pkgStatus{Perl}{pkgs}{$pkg}{status} eq 'installed' || $pkg eq 'perl' ) { my $reqV = $modPreqs->{$mAttr}{$pkg}; my $instV = $pkgStatus{Perl}{installed}{$pkg}; if ( defined($reqV) && $reqV ne '' && $reqV ne '0' && defined($instV) && $instV ne '' && $instV ne '0' ) { $reqV = version->parse($reqV)->numify; $instV = version->parse($instV)->numify; #TODO suport for version range: # https://metacpan.org/pod/ \ # CPAN::Meta::Spec#Version-Range if ( $reqV > 0 && $instV < $reqV ) { $pkgStatus{Perl}{pkgs}{$pkg}{status} = 'outdated'; push @{ $pkgStatus{Perl}{outdated}{$pkg} }, $reqV; $pkgStatus{Perl}{analyzed} = 1 if ( $modMeta->{x_prereqs_src} ne 'META.json' && !$pkgStatus{Perl}{analyzed} ); } } } $pkgStatus{Perl}{pkgs}{$pkg}{timestamp} = $t; } } } #TODO # nodejs # python } } # build installation hash foreach my $area ( keys %pkgStatus ) { foreach my $t (qw(missing outdated)) { if ( defined( $pkgStatus{$area}{$t} ) && ref( $pkgStatus{$area}{$t} ) eq 'HASH' && scalar keys %{ $pkgStatus{$area}{$t} } > 0 ) { foreach my $pkg ( keys %{ $pkgStatus{$area}{$t} } ) { next unless ( ref( $pkgStatus{$area}{$t}{$pkg} ) eq 'ARRAY' ); # detect minimum required version # for missing and outdated packages my $v = maxNum( 0, @{ $pkgStatus{$area}{$t}{$pkg} } ); $pkgStatus{$area}{$t}{$pkg} = $v; if ( defined( $pkgStatus{$area}{pkgs}{$pkg}{modules}{requires} ) && @{ $pkgStatus{$area}{pkgs}{$pkg}{modules}{requires} } > 0 ) { $pkgStatus{counter}{total}++; $pkgStatus{counter}{$t}++; $pkgStatus{counter}{required}{total}++; $pkgStatus{counter}{required}{$t}++; $pkgStatus{counter}{required}{$area}{total}++; $pkgStatus{counter}{required}{$area}{$t}++; $pkgStatus{counter}{$area}{total}++; $pkgStatus{counter}{$area}{$t}++; $pkgStatus{counter}{$area}{required}{total}++; $pkgStatus{counter}{$area}{required}{$t}++; $pkgStatus{required}{$area}{$pkg}{status} = $t; $pkgStatus{required}{$area}{$pkg}{version} = $v; $pkgStatus{required}{$area}{$pkg}{modules} = $pkgStatus{$area}{pkgs}{$pkg}{modules}{requires}; # add other modules if ( defined( $pkgStatus{$area}{pkgs}{$pkg}{modules} {recommends} ) && @{ $pkgStatus{$area}{pkgs}{$pkg}{modules} {recommends} } > 0 ) { foreach my $modName ( @{ $pkgStatus{$area}{pkgs}{$pkg}{modules} {recommends} } ) { push @{ $pkgStatus{required}{$area}{$pkg}{modules} }, $modName unless ( grep ( /^$modName$/, @{ $pkgStatus{required}{$area} {$pkg}{modules} } ) ); } } if ( defined( $pkgStatus{$area}{pkgs}{$pkg}{modules}{suggests} ) && @{ $pkgStatus{$area}{pkgs}{$pkg}{modules}{suggests} } > 0 ) { foreach my $modName ( @{ $pkgStatus{$area}{pkgs}{$pkg}{modules} {suggests} } ) { push @{ $pkgStatus{required}{$area}{$pkg}{modules} }, $modName unless ( grep ( /^$modName$/, @{ $pkgStatus{required}{$area} {$pkg}{modules} } ) ); } } } elsif ( defined( $pkgStatus{$area}{pkgs}{$pkg}{modules}{recommends} ) && @{ $pkgStatus{$area}{pkgs}{$pkg}{modules}{recommends} } > 0 ) { $pkgStatus{counter}{total}++; $pkgStatus{counter}{$t}++; $pkgStatus{counter}{recommended}{total}++; $pkgStatus{counter}{recommended}{$t}++; $pkgStatus{counter}{recommended}{$area}{total}++; $pkgStatus{counter}{recommended}{$area}{$t}++; $pkgStatus{counter}{$area}{total}++; $pkgStatus{counter}{$area}{$t}++; $pkgStatus{counter}{$area}{recommended}{total}++; $pkgStatus{counter}{$area}{recommended}{$t}++; $pkgStatus{recommended}{$area}{$pkg}{status} = $t; $pkgStatus{recommended}{$area}{$pkg}{version} = $v; $pkgStatus{recommended}{$area}{$pkg}{modules} = $pkgStatus{$area}{pkgs}{$pkg}{modules}{recommends}; # add other modules if ( defined( $pkgStatus{$area}{pkgs}{$pkg}{modules}{suggests} ) && @{ $pkgStatus{$area}{pkgs}{$pkg}{modules}{suggests} } > 0 ) { foreach my $modName ( @{ $pkgStatus{$area}{pkgs}{$pkg}{modules} {suggests} } ) { push @{ $pkgStatus{recommended}{$area}{$pkg} {modules} }, $modName unless ( grep ( /^$modName$/, @{ $pkgStatus{recommended}{$area} {$pkg}{modules} } ) ); } } } elsif ( defined( $pkgStatus{$area}{pkgs}{$pkg}{modules}{suggests} ) && @{ $pkgStatus{$area}{pkgs}{$pkg}{modules}{suggests} } > 0 ) { $pkgStatus{counter}{total}++; $pkgStatus{counter}{$t}++; $pkgStatus{counter}{suggested}{total}++; $pkgStatus{counter}{suggested}{$t}++; $pkgStatus{counter}{suggested}{$area}{total}++; $pkgStatus{counter}{suggested}{$area}{$t}++; $pkgStatus{counter}{$area}{total}++; $pkgStatus{counter}{$area}{$t}++; $pkgStatus{counter}{$area}{suggested}{total}++; $pkgStatus{counter}{$area}{suggested}{$t}++; $pkgStatus{suggested}{$area}{$pkg}{status} = $t; $pkgStatus{suggested}{$area}{$pkg}{version} = $v; $pkgStatus{suggested}{$area}{$pkg}{modules} = $pkgStatus{$area}{pkgs}{$pkg}{modules}{suggests}; } } } else { $pkgStatus{counter}{$t} = 0; $pkgStatus{counter}{required}{$t} = 0; $pkgStatus{counter}{required}{$area}{$t} = 0; $pkgStatus{counter}{recommended}{$t} = 0; $pkgStatus{counter}{recommended}{$area}{$t} = 0; $pkgStatus{counter}{suggested}{$t} = 0; $pkgStatus{counter}{suggested}{$area}{$t} = 0; $pkgStatus{counter}{$area}{$t} = 0; $pkgStatus{counter}{$area}{required}{$t} = 0; $pkgStatus{counter}{$area}{recommended}{$t} = 0; $pkgStatus{counter}{$area}{suggested}{$t} = 0; } } } if (@rets) { $@ = join( "\n", @rets ); return "$@"; } return undef; } #TODO # Checks whether a NodeJS package is installed in the system sub __IsInstalledNodejs($) { return 0 unless ( __PACKAGE__ eq caller(0) ); return 0 unless (@_); my ($pkg) = @_; return 0; } #TODO # Checks whether a Python package is installed in the system sub __IsInstalledPython($) { return 0 unless ( __PACKAGE__ eq caller(0) ); return 0 unless (@_); my ($pkg) = @_; return 0; } sub __GetExtendedEnvPath { return 0 unless ( __PACKAGE__ eq caller(0) ); my @binpath = ( $Config::Config{'installsitebin'}, $Config::Config{'installsitescript'}, $Config::Config{'sitebin'}, $Config::Config{'sitescript'}, $Config::Config{'installscript'}, $Config::Config{'installvendorbin'}, $Config::Config{'installvendorscript'}, $Config::Config{'initialinstalllocation'}, $Config::Config{'bin'} ); my @path = split( /:/, $ENV{PATH} ); foreach my $p ( reverse @binpath ) { next unless ( $p && $p ne '' ); $p =~ s/\\/\\\\/g if ( $^O =~ m/Win/ ); unshift @path, $p unless ( grep ( /^$p$/, @path ) ); } return join( ":", @path ); } sub __ToDay() { my ( $sec, $min, $hour, $mday, $month, $year, $wday, $yday, $isdst ) = localtime( gettimeofday() ); $month++; $year += 1900; my $today = sprintf( '%04d-%02d-%02d', $year, $month, $mday ); return $today; } sub __aUniq { my %seen; grep !$seen{$_}++, @_; } use B qw/svref_2object/; sub __in_package { return 0 unless ( __PACKAGE__ eq caller(0) ); my ( $coderef, $package ) = @_; my $cv = svref_2object($coderef); return if not $cv->isa('B::CV') or $cv->GV->isa('B::SPECIAL'); return $cv->GV->STASH->NAME eq $package; } sub __list_module { return 0 unless ( __PACKAGE__ eq caller(0) ); my $module = shift; my $inPackage = shift; no strict 'refs'; return grep { defined &{"$module\::$_"} and ( $inPackage ? __in_package( \&{*$_}, $module ) : 1 ) } keys %{"$module\::"}; } 1; =pod =encoding utf8 =item helper =item summary Module to help with FHEM installations =item summary_DE Modul zur Unterstuetzung bei FHEM Installationen =begin html

Installer

    Installer - Module to update FHEM, install 3rd-party FHEM modules and manage system prerequisites


    Define
      define <name> Installer

      Example:
        define fhemInstaller Installer



    Get
    • checkPrereqs - list all missing prerequisites. If no parameter was given, the running live system will be inspected. If the parameter is a FHEM cfg file, inspection will be based on devices from this file. If the parameter is a list of module names, those will be used for inspection.
    • search - search FHEM for device names, module names, package names, keywords, authors and Perl package names.
    • showModuleInfo - list information about a specific FHEM module
    • showPackageInfo - list information about a specific FHEM package
    • zzGetModuleMETA.json - prints raw meta information of a FHEM module in JSON format
    • zzGetPackageMETA.json - prints raw meta information of a FHEM package in JSON format


    Attributes
    • disable - disables the device
    • disabledForIntervals - disable device for interval time (13:00-18:30 or 13:00-18:30 22:00-23:00)
    • installerMode - sets the installation mode. May be update, developer or install with update being the default setting. Some get and/or set commands may be hidden or limited depending on this.
=end html =begin html_DE

Installer

    Eine deutsche Version der Dokumentation ist derzeit nicht vorhanden. Die englische Version ist hier zu finden:
=end html_DE =for :application/json;q=META.json 98_Installer.pm { "abstract": "Module to update FHEM, install 3rd-party FHEM modules and manage system prerequisites", "x_lang": { "de": { "abstract": "Modul zum Update von FHEM, zur Installation von Drittanbieter FHEM Modulen und der Verwaltung von Systemvoraussetzungen" } }, "version": "v0.5.7", "release_status": "stable", "author": [ "Julian Pawlowski " ], "x_fhem_maintainer": [ "loredo" ], "x_fhem_maintainer_github": [ "jpawlowski" ], "keywords": [ "Dependencies", "Prerequisites", "Setup" ], "prereqs": { "runtime": { "requires": { "Data::Dumper": 0, "Encode": 0, "FHEM": 5.00918623, "FHEM::Meta": 0.001006, "FHEM::npmjs": 0, "File::stat": 0, "GPUtils": 0, "HttpUtils": 0, "IO::Socket::SSL": 0, "Config": 0, "ExtUtils::Installed": 0, "B": 0, "JSON::PP": 0, "perl": 5.014, "version": 0, "SubProcess": 0 }, "recommends": { "Perl::PrereqScanner::NotQuiteLite": 0, "JSON": 0 }, "suggests": { "Cpanel::JSON::XS": 0, "JSON::XS": 0 } } }, "resources": { "bugtracker": { "web": "https://github.com/fhem/Installer/issues" } } } =end :application/json;q=META.json =cut