diff options
Diffstat (limited to 'src/lib/OpenSLX/Basics.pm')
| -rw-r--r-- | src/lib/OpenSLX/Basics.pm | 856 |
1 files changed, 856 insertions, 0 deletions
diff --git a/src/lib/OpenSLX/Basics.pm b/src/lib/OpenSLX/Basics.pm new file mode 100644 index 00000000..4ac40166 --- /dev/null +++ b/src/lib/OpenSLX/Basics.pm @@ -0,0 +1,856 @@ +# Copyright (c) 2006, 2007 - OpenSLX GmbH +# +# This program is free software distributed under the GPL version 2. +# See http://openslx.org/COPYING +# +# If you have any feedback please consult http://openslx.org/feedback and +# send your suggestions, praise, or complaints to feedback@openslx.org +# +# General information about OpenSLX can be found at http://openslx.org/ +# ----------------------------------------------------------------------------- +package OpenSLX::Basics; + +use strict; +use warnings; + +our (@ISA, @EXPORT, $VERSION); + +use Exporter; +$VERSION = 1.01; +@ISA = qw(Exporter); + +@EXPORT = qw( + &openslxInit %openslxConfig %cmdlineConfig + &_tr + &warn &die &croak &carp &confess &cluck + &callInSubprocess &executeInSubprocess &slxsystem + &vlog + &checkParams + &instantiateClass &loadDistroModule +); + +=head1 NAME + +OpenSLX::Basics - implements basic functionality for OpenSLX. + +=head1 DESCRIPTION + +This module exports basic functions, which are expected to be used all across +OpenSLX. + +=cut + +our (%openslxConfig, %cmdlineConfig, %openslxPath); + +use subs qw(die warn); + +use open ':utf8'; + +require Carp; # do not import anything as we are going to overload carp + # and croak! +use Config::General; +use Encode; +use FindBin; +use Getopt::Long; +use POSIX qw(locale_h); + +my $translations; + +=head1 PUBLIC VARIABLES + +=over + +=item B<%openslxConfig> + +This hash holds the active openslx configuration. + +The initial content is based on environment variables or default values. Calling +C<openslxInit()> will read the configuration files and/or cmdline arguments +and modify this hash accordingly. + +The individual entries of this hash are documented in the manual of the +I<slxsettings>-script, so please look there if you'd like to know more. + +=cut + +%openslxConfig = ( + 'db-name' => $ENV{SLX_DB_NAME} || 'openslx', + 'db-spec' => $ENV{SLX_DB_SPEC}, + 'db-type' => $ENV{SLX_DB_TYPE} || 'SQLite', + 'locale' => setlocale(LC_MESSAGES), + 'locale-charmap' => `locale charmap`, + 'base-path' => $ENV{SLX_BASE_PATH} || '/opt/openslx', + 'config-path' => $ENV{SLX_CONFIG_PATH} || '/etc/opt/openslx', + 'log-level' => $ENV{SLX_VERBOSE_LEVEL} || '0', + 'private-path' => $ENV{SLX_PRIVATE_PATH} || '/var/opt/openslx', + 'public-path' => $ENV{SLX_PUBLIC_PATH} || '/srv/openslx', + 'temp-path' => $ENV{SLX_TEMP_PATH} || '/tmp', + + # + # options useful during development only: + # + 'debug-confess' => '0', + # + # only settable programmatically: + # + 'log-pids' => '0', + + # + # extended settings follow, which are only supported by slxsettings, + # but not by any other script: + # + 'db-user' => undef, + 'db-passwd' => undef, + 'default-shell' => 'bash', + 'default-timezone' => 'Europe/Berlin', + 'mirrors-preferred-top-level-domain' => undef, + 'mirrors-to-try-count' => '20', + 'mirrors-to-use-count' => '5', + 'ossetup-max-try-count' => '5', + 'pxe-default-menu-entry' => undef, + 'pxe-passwd' => 'secret', + 'pxe-timeout' => '100', + 'pxe-title' => 'Welcome to OpenSLX', + 'pxe-totaltimeout' => '600', + 'syslinux-theme' => 'openslx', +); +chomp($openslxConfig{'locale-charmap'}); + +=item B<%cmdlineConfig> + +This hash holds the config items that were specified via cmdline. This can be +useful if you need to find out which settings have been specified via cmdline +and which ones have come from a config file. + +Currently, only the slxsettings script and some tests make use of this hash. + +=cut + +# specification of cmdline arguments that are shared by all openslx-scripts: +my %openslxCmdlineArgs = ( + + # name of database, defaults to 'openslx' + 'db-name=s' => \$cmdlineConfig{'db-name'}, + + # full specification of database, a special string defining the + # precise database to connect to (the contents of this string + # depend on db-type) + 'db-spec=s' => \$cmdlineConfig{'db-spec'}, + + # type of database to connect to (SQLite, mysql, ...), defaults to 'SQLite' + 'db-type=s' => \$cmdlineConfig{'db-type'}, + + # activates debug mode, this will show the lines where any error occured + # (followed by a stacktrace): + 'debug-confess' => \$cmdlineConfig{'debug-confess'}, + + # locale to use for translations + 'locale=s' => \$cmdlineConfig{'locale'}, + + # locale-charmap to use for I/O (iso-8859-1, utf-8, etc.) + 'locale-charmap=s' => \$cmdlineConfig{'locale-charmap'}, + + # level of logging verbosity (0-3) + 'log-level=i' => \$cmdlineConfig{'log-level'}, + + # file to write logging output to, defaults to STDERR + 'logfile=s' => \$cmdlineConfig{'locale'}, + + # path to private data (which is *not* accesible by clients and contains + # database, vendorOSes and all local extensions [system specific scripts]) + 'private-path=s' => \$cmdlineConfig{'private-path'}, + + # path to public data (which is accesible by clients and contains + # PXE-configurations, kernels, initramfs and client configurations) + 'public-path=s' => \$cmdlineConfig{'public-path'}, + + # path to temporary data (used during demuxing) + 'temp-path=s' => \$cmdlineConfig{'temp-path'}, +); + +# filehandle used for logging: +my $openslxLog = *STDERR; + +$Carp::CarpLevel = 1; + +=back + +=head1 PUBLIC FUNCTIONS + +=over + +=item B<openslxInit()> + +Initializes OpenSLX environment - every script should invoke this function +before it invokes any other. + +Basically, this function reads in the configuration and sets up logging +and translation backends. + +Returns 1 upon success and dies in case of a problem. + +=cut + +sub openslxInit +{ + # evaluate cmdline arguments: + Getopt::Long::Configure('no_pass_through'); + GetOptions(%openslxCmdlineArgs); + + # try to read and evaluate config files: + my $configPath + = $cmdlineConfig{'config-path'} || $openslxConfig{'config-path'}; + my $sharePath = "$openslxConfig{'base-path'}/share"; + my $verboseLevel = $cmdlineConfig{'log-level'} || 0; + foreach my $f ( + "$sharePath/settings.default", + "$configPath/settings", + "$ENV{HOME}/.openslx/settings" + ) { + next unless -e $f; + if ($verboseLevel >= 2) { + vlog(0, "reading config-file $f..."); + } + my $configObject = Config::General->new( + -AutoTrue => 1, + -ConfigFile => $f, + -LowerCaseNames => 1, + -SplitPolicy => 'equalsign', + ); + my %config = $configObject->getall(); + foreach my $key (keys %config) { + # N.B.: these config files are used by shell-scripts, too, so in + # order to comply with shell-style, the config files use shell + # syntax and an uppercase, underline-as-separator format. + # Internally, we use lowercase, minus-as-separator format, so we + # need to convert the environment variable names to our own + # internal style here (e.g. 'SLX_BASE_PATH' to 'base-path'): + my $ourKey = $key; + $ourKey =~ s[^slx_][]; + $ourKey =~ tr/_/-/; + $openslxConfig{$ourKey} = $config{$key}; + } + } + + # push any cmdline argument into our config hash, possibly overriding any + # setting from the config files: + while (my ($key, $val) = each(%cmdlineConfig)) { + next unless defined $val; + $openslxConfig{$key} = $val; + } + + if (defined $openslxConfig{'logfile'}) { + open($openslxLog, '>>', $openslxConfig{'logfile'}) + or croak( + _tr( + "unable to append to logfile '%s'! (%s)", + $openslxConfig{'logfile'}, $! + ) + ); + } + if ($openslxConfig{'log-level'} >= 2) { + foreach my $key (sort keys %openslxConfig) { + my $val = $openslxConfig{$key} || ''; + vlog(2, "config-dump: $key = $val"); + } + } + + # setup translation "engine": + _trInit(); + + return 1; +} + +=item B<vlog($level, $message)> + +Logs the given I<$message> if the current log level is equal or greater than +the given I<$level>. + +=cut + +sub vlog +{ + my $minLevel = shift; + return if $minLevel > $openslxConfig{'log-level'}; + my $str = join("", '-' x $minLevel, @_); + if (substr($str, -1, 1) ne "\n") { + $str .= "\n"; + } + if ($openslxConfig{'log-pids'}) { + print $openslxLog "$$: $str"; + } else { + print $openslxLog $str; + } + return; +} + +=item B<_tr($originalMsg, @msgParams)> + +Translates the english text given in I<$originalMsg> to the currently selected +language, passing on any given additional I<$msgParams> to the translation +process (as printf arguments). + +N.B.: although it starts with an underscore, this is still a public function! + +=cut + +sub _tr +{ + my $trOrig = shift; + + my $trKey = $trOrig; + $trKey =~ s[\n][\\n]g; + $trKey =~ s[\t][\\t]g; + + my $formatStr; + if (defined $translations) { + $formatStr = $translations->{$trKey}; + } + if (!defined $formatStr) { + $formatStr = $trOrig; + } + return sprintf($formatStr, @_); +} + +=item B<callInSubprocess($childFunc)> + +Forks the current process and invokes the code given in I<$childFunc> in the +child process. The parent blocks until the child has executed that function. + +If an error occured during execution of I<$childFunc>, the parent process will +cleanup the child and then pass back that error with an invocation of die(). + +If the process of executing I<$childFunc> is being interrupted by a signal, +the parent will cleanup and then exit with an appropriate exit code. + +=cut + +sub callInSubprocess +{ + my $childFunc = shift; + + my $pid = fork(); + if (!$pid) { + # child -> execute the given function and exit: + if (! eval { $childFunc->(); 1 }) { + $@ = "*** $@" unless substr( $@, 0, 4) eq '*** '; + print STDERR "$@\n"; + } + exit 0; + } + + # parent -> pass on interrupt- and terminate-signals to child ... + $SIG{INT} = sub { kill 'INT', $pid; }; + $SIG{TERM} = sub { kill 'TERM', $pid; }; + + # ... and wait until child has done its work + waitpid($pid, 0); + exit $? if $?; + + return; +} + +=item B<executeInSubprocess(@cmdlineArgs)> + +Forks the current process and executes the program given in I<@cmdlineArgs> in +the child process. + +The parent process returns immediately after having spawned the new process, +returning the process-ID of the child. + +=cut + +sub executeInSubprocess +{ + my @cmdlineArgs = @_; + + my $pid = fork(); + if (!$pid) { + + # child... + # ...exec the given cmdline: + exec(@cmdlineArgs); + } + + # parent... + return $pid; +} + +=item B<slxsystem(@cmdlineArgs)> + +Executes a new program specified by I<@cmdlineArgs> and waits until it is done. + +Returns the exit code of the execution (usually 0 if everything is ok). + +If any signal (other than SIGPIPE) interrupts the execution, this function +dies with an appropriate error message. SIGPIPE is being ignored in order +to ignore any failed FTP connections and the like (we just return the +error code instead). + +=cut + +sub slxsystem +{ + vlog(2, _tr("executing: %s", join ' ', @_)); + my $res = system(@_); + if ($res > 0) { + # check if child got killed, if so we stop, too (unless the signal is + # SIGPIPE, which we ignore in order to loop over failed FTP connections + # and the like): + my $signalNo = $res & 127; + if ($signalNo > 0 && $signalNo != 13) { + die _tr( + "child-process received signal '%s', parent stops!", $signalNo + ); + } + } + return $res; +} + +=item B<cluck()>, B<carp()>, B<warn()>, B<confess()>, B<croak()>, B<die()> + +Overrides of the respective functions in I<Carp::> or I<CORE::> that mark +any warnings with '°°°' and any errors with '***' in order to make them +more visible in the output. + +=cut + +sub cluck +{ + _doThrowOrWarn('cluck', @_); + return; +} + +sub carp +{ + _doThrowOrWarn('carp', @_); + return; +} + +sub warn +{ + _doThrowOrWarn('warn', @_); + return; +} + +sub confess +{ + _doThrowOrWarn('confess', @_); + return; +} + +sub croak +{ + _doThrowOrWarn('croak', @_); + return; +} + +sub die +{ + _doThrowOrWarn('die', @_); + return; +} + +=item B<checkParams($params, $paramsSpec)> + +Utility function that can be used by any function that accepts param-hashes +to check if the parameters given in I<$params> actually match the expectations +specified in I<$paramsSpec>. + +Each individual parameter has a specification that describes the expectation +that the calling function has towards this param. The following specifications +are supported: + +* '!' - the parameter is required +* '?' - the parameter is optional +* 'm{regex}' - the parameter must match the given regex +* '!class=...' - the parameter is required and must be an object of the given class +* '?class=...' - if the parameter has been given, it must be an object of the given class + +The function will confess for any unknown, missing, or non-matching param. + +=cut + +sub checkParams +{ + my $params = shift or confess('need to pass in params-hashref!'); + my $paramsSpec = shift or confess('need to pass in params-spec-hashref!'); + + # print a warning for any unknown parameters that have been given: + my @unknownParams + = grep { !exists $paramsSpec->{$_}; } + keys %$params; + if (@unknownParams) { + my $unknownParamsStr = join ',', @unknownParams; + confess("Enocuntered unknown params: '$unknownParamsStr'!\n"); + } + + # check if all required params have been specified: + foreach my $param (keys %$paramsSpec) { + my $spec = $paramsSpec->{$param}; + if (ref($spec) eq 'HASH') { + # Handle nested specs by recursion: + my $subParams = $params->{$param}; + if (!defined $subParams) { + confess("Required param '$param' is missing!"); + } + checkParams($subParams, $spec); + } + elsif (ref($spec) eq 'ARRAY') { + # Handle nested spec arrays by looped recursion: + my $subParams = $params->{$param}; + if (!defined $subParams) { + confess("Required param '$param' is missing!"); + } + elsif (ref($subParams) ne 'ARRAY') { + confess("Value for param '$param' must be an array-ref!"); + } + foreach my $subParam (@$subParams) { + checkParams($subParam, $spec->[0]); + } + } + elsif ($spec eq '!') { + # required parameter: + if (!exists $params->{$param}) { + confess("Required param '$param' is missing!"); + } + } + elsif ($spec =~ m{^\!class=(.+)$}i) { + my $class = $1; + # required parameter ... + if (!exists $params->{$param}) { + confess("Required param '$param' is missing!"); + } + # ... of specific class + if (!$params->{$param}->isa($class)) { + confess("Param '$param' is not a '$class', but that is required!"); + } + } + elsif ($spec eq '?') { + # optional parameter - nothing to do + } + elsif ($spec =~ m{^\?class=(.+)$}i) { + my $class = $1; + # optional parameter ... + if (exists $params->{$param}) { + # ... has been given, so it must match specific class + if (!$params->{$param}->isa($class)) { + confess("Param '$param' is not a '$class', but that is required!"); + } + } + } + elsif ($spec =~ m{^m{(.+)}$}) { + # try to match given regex: + my $regex = $1; + my $value = $params->{$param}; + if ($value !~ m{$regex}) { + confess("Required param '$param' isn't matching regex '$regex' (given value was '$value')!"); + } + } + else { + # complain about unknown spec: + confess("Unknown param-spec '$spec' encountered!"); + } + } + + return scalar 1; +} + +=item B<instantiateClass($class, $flags)> + +Loads the required module and instantiates an object of the class given in +I<$class>. + +The following flags can be specified via I<$flags>-hashref: + +=over + +=item acceptMissing [optional] + +Usually, this function will die if the corresponding module could not be found +(acceptMissing == 0). Pass in acceptMissing => 1 if you want this function +to return undef instead. + +=item pathToClass [optional] + +Sometimes, the module specified in I<$class> lives relative to another path. +If so, you can specify the base path of that module via this flag. + +=item incPaths [optional] + +Some modules live outside of the standard perl search paths. If you'd like to +load such a module, you can specify one (or more) paths that will be added +to @INC while trying to load the module. + +=item version [optional] + +If you require a specific version of the module, you can specify the version +number via the I<$version> flag. + +=back + +=cut + +sub instantiateClass +{ + my $class = shift; + my $flags = shift || {}; + + checkParams($flags, { + 'acceptMissing' => '?', + 'pathToClass' => '?', + 'incPaths' => '?', + 'version' => '?', + }); + my $pathToClass = $flags->{pathToClass}; + my $requestedVersion = $flags->{version}; + my $incPaths = $flags->{incPaths} || []; + + my $moduleName = defined $pathToClass ? "$pathToClass/$class" : $class; + $moduleName =~ s[::][/]g; + $moduleName .= '.pm'; + + vlog(3, "trying to load $moduleName..."); + local @INC = @INC; + foreach my $incPath (@$incPaths) { + next if grep { $_ eq $incPath } @INC; + unshift @INC, $incPath; + } + if (!eval { require $moduleName; 1 } ) { + # check if module does not exists anywhere in search path + if ($! == 2) { + return if $flags->{acceptMissing}; + die _tr("Module '%s' not found!\n", $moduleName); + } + # some other error (probably compilation problems) + die _tr("Unable to load module '%s' (%s)\n", $moduleName, $@); + } + if (defined $requestedVersion) { + my $classVersion = $class->VERSION; + if ($classVersion < $requestedVersion) { + die _tr( + 'Could not load class <%s> (Version <%s> required, but <%s> found)', + $class, $requestedVersion, $classVersion); + } + } + return $class->new; +} + +=item B<loadDistroModule($params)> + +Tries to determine the most appropriate distro module for the context specified +via the given I<$params>. + +During that process, this function will try to load several different modules, +working its way from the most specific down to a generic fallback. + +For example: when given I<suse-10.3_x86_64> as distroName, this function would +try the following modules: + +=over + +=item I<Suse_10_3_x86_64> + +=item I<Suse_10_3> + +=item I<Suse_10> + +=item I<Suse> + +=item I<Base> (or whatever has been given as fallback name) + +=back + +The I<$params>-hashref supports the following entries: + +=over + +=item distroName + +Specifies the name of the distro as it was retrieved from the vendor-OS +(e.g. 'suse-10.2' or 'ubuntu-8.04_amd64'). + +=item distroScope + +Specifies the scope of the required distro class (e.g. +'OpenSLX::OSSetup::Distro' or 'vmware::OpenSLX::Distro'). + +=item fallbackName [optional] + +Instead of the default 'Base', you can specify the name of a different fallback +class that will be tried if no module matching the given distro name could be +found. + +=item pathToClass [optional] + +If you require the distro modules to be loaded relative to a specific path, +you can specify that base path via the I<$pathToClass> param. + +=back + +=cut + +sub loadDistroModule +{ + my $params = shift; + + checkParams($params, { + 'distroName' => '!', + 'distroScope' => '!', + 'fallbackName' => '?', + 'pathToClass' => '?', + }); + my $distroName = ucfirst(lc($params->{distroName})); + my $distroScope = $params->{distroScope}; + my $fallbackName = $params->{fallbackName} || 'Base'; + my $pathToClass = $params->{pathToClass}; + + vlog(1, "finding a ${distroScope} module for $distroName ..."); + + # try to load the distro module starting with the given name and then + # working the way upwards (from most specific to generic). + $distroName =~ tr{.-}{__}; + my @distroModules; + my $blockRX = qr{ + ^(.+?)_ # everything before the last block (the rest is dropped) + (?:x86_)? # takes care to treat 'x86_64' as one block + [^_]*$ # the last _-block + }x; + while($distroName =~ m{$blockRX}) { + push @distroModules, $distroName; + $distroName = $1; + } + push @distroModules, $distroName; + push @distroModules, $fallbackName; + + my $pluginBasePath = "$openslxConfig{'base-path'}/lib/plugins"; + + my $distro; + for my $distroModule (@distroModules) { + my $loaded = eval { + vlog(1, "trying ${distroScope}::$distroModule ..."); + my $flags = { acceptMissing => 1 }; + if ($pathToClass) { + $flags->{incPaths} = [ $pathToClass ]; + } + $distro = instantiateClass("${distroScope}::$distroModule", $flags); + return 0 if !$distro; # module does not exist, try next + vlog(1, "ok - using ${distroScope}::$distroModule."); + 1; + }; + last if $loaded; + if (!defined $loaded) { + die _tr( + "Error when trying to load distro module '%s':\n%s", + $distroModule, $@ + ); + } + } + + return $distro; +} + +sub _trInit +{ + # activate automatic charset conversion on all the standard I/O streams, + # just to give *some* support to shells in other charsets: + binmode(STDIN, ":encoding($openslxConfig{'locale-charmap'})"); + binmode(STDOUT, ":encoding($openslxConfig{'locale-charmap'})"); + binmode(STDERR, ":encoding($openslxConfig{'locale-charmap'})"); + + my $locale = $openslxConfig{'locale'}; + if (lc($locale) eq 'c') { + # treat locale 'c' as equivalent for 'posix': + $locale = 'posix'; + } + + if (lc($locale) ne 'posix') { + # parse locale and canonicalize it (e.g. to 'de_DE') and generate + # two filenames from it (language+country and language only): + if ($locale !~ m{^\s*([^_]+)(?:_(\w+))?}) { + die "locale $locale has unknown format!?!"; + } + my @locales; + if (defined $2) { + push @locales, lc($1) . '_' . uc($2); + } + push @locales, lc($1); + + # try to load any of the Translation modules (starting with the more + # specific one [language+country]): + my $loadedTranslationModule; + foreach my $trName (@locales) { + vlog(2, "trying to load translation module $trName..."); + my $trModule = "OpenSLX/Translations/$trName.pm"; + my $trModuleSpec = "OpenSLX::Translations::$trName"; + if (eval { require $trModule } ) { + # copy the translations available in the given locale into our + # hash: + $translations = $trModuleSpec->getAllTranslations(); + $loadedTranslationModule = $trModule; + vlog( + 1, + _tr( + "translations module %s loaded successfully", $trModule + ) + ); + last; + } + } + if (!defined $loadedTranslationModule) { + vlog(1, + "unable to load any translations module for locale '$locale' ($!)." + ); + } + } + return; +} + +sub _doThrowOrWarn +{ + my $type = shift; + my $msg = shift; + + # use '! ' for warnings and '***' for errors + $msg =~ s[^(! |\*\*\*) ][]gms; + if ($type eq 'carp' || $type eq 'warn' || $type eq 'cluck') { + $msg =~ s[^][! ]gms; + } + else { + $msg =~ s[^][*** ]gms; + } + + if ($openslxConfig{'debug-confess'}) { + my %functionFor = ( + 'carp' => sub { Carp::cluck @_ }, + 'cluck' => sub { Carp::cluck @_ }, + 'confess' => sub { Carp::confess @_ }, + 'croak' => sub { Carp::confess @_ }, + 'die' => sub { Carp::confess @_ }, + 'warn' => sub { Carp::cluck @_ }, + ); + my $func = $functionFor{$type}; + $func->($msg); + } + else { + chomp $msg; + my %functionFor = ( + 'carp' => sub { Carp::carp @_ }, + 'cluck' => sub { Carp::cluck @_ }, + 'confess' => sub { Carp::confess @_ }, + 'croak' => sub { Carp::croak @_ }, + 'die' => sub { CORE::die @_}, + 'warn' => sub { CORE::warn @_ }, + ); + my $func = $functionFor{$type}; + $func->("$msg\n"); + } + return; +} + + +=back + +=cut + +1; |