From 416ab8a37f1b07dc9f6c0fb3ff1a8ff2036510b5 Mon Sep 17 00:00:00 2001 From: Sebastian Schmelzer Date: Thu, 2 Sep 2010 17:50:49 +0200 Subject: change dir structure --- src/lib/OpenSLX/Basics.pm | 856 ++++++++++++++++++++++++++++++++ src/lib/OpenSLX/ConfigFolder.pm | 154 ++++++ src/lib/OpenSLX/DistroUtils.pm | 90 ++++ src/lib/OpenSLX/DistroUtils/Base.pm | 429 ++++++++++++++++ src/lib/OpenSLX/DistroUtils/Engine.pm | 58 +++ src/lib/OpenSLX/DistroUtils/InitFile.pm | 232 +++++++++ src/lib/OpenSLX/DistroUtils/Suse.pm | 174 +++++++ src/lib/OpenSLX/DistroUtils/Ubuntu.pm | 172 +++++++ src/lib/OpenSLX/LibScanner.pm | 262 ++++++++++ src/lib/OpenSLX/ScopedResource.pm | 174 +++++++ src/lib/OpenSLX/Syscall.pm | 129 +++++ src/lib/OpenSLX/Translations/de.pm | 359 ++++++++++++++ src/lib/OpenSLX/Translations/posix.pm | 359 ++++++++++++++ src/lib/OpenSLX/Utils.pm | 701 ++++++++++++++++++++++++++ 14 files changed, 4149 insertions(+) create mode 100644 src/lib/OpenSLX/Basics.pm create mode 100644 src/lib/OpenSLX/ConfigFolder.pm create mode 100644 src/lib/OpenSLX/DistroUtils.pm create mode 100644 src/lib/OpenSLX/DistroUtils/Base.pm create mode 100644 src/lib/OpenSLX/DistroUtils/Engine.pm create mode 100644 src/lib/OpenSLX/DistroUtils/InitFile.pm create mode 100644 src/lib/OpenSLX/DistroUtils/Suse.pm create mode 100644 src/lib/OpenSLX/DistroUtils/Ubuntu.pm create mode 100644 src/lib/OpenSLX/LibScanner.pm create mode 100644 src/lib/OpenSLX/ScopedResource.pm create mode 100644 src/lib/OpenSLX/Syscall.pm create mode 100644 src/lib/OpenSLX/Translations/de.pm create mode 100644 src/lib/OpenSLX/Translations/posix.pm create mode 100644 src/lib/OpenSLX/Utils.pm (limited to 'src/lib/OpenSLX') 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 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-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 + +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 + +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 + +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 + +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 + +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, B, B, B, B, B + +Overrides of the respective functions in I or I 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 + +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 + +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 + +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 as distroName, this function would +try the following modules: + +=over + +=item I + +=item I + +=item I + +=item I + +=item I (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; diff --git a/src/lib/OpenSLX/ConfigFolder.pm b/src/lib/OpenSLX/ConfigFolder.pm new file mode 100644 index 00000000..fd52821e --- /dev/null +++ b/src/lib/OpenSLX/ConfigFolder.pm @@ -0,0 +1,154 @@ +# 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::ConfigFolder; + +use strict; +use warnings; + +our (@ISA, @EXPORT, $VERSION); + +use Exporter; +$VERSION = 1.01; +@ISA = qw(Exporter); + +@EXPORT = qw( + &createConfigFolderForDefaultSystem + &createConfigFolderForSystem +); + +=head1 NAME + +OpenSLX::ConfigFolder - implements configuration folder related functionality +for OpenSLX. + +=head1 DESCRIPTION + +This module exports functions that create configuration folders for specific +system, which will be used by the slxconfig-demuxer when building an initramfs +for each system. + +=cut + +use OpenSLX::Basics; +use OpenSLX::Utils; + +=head1 PUBLIC FUNCTIONS + +=over + +=item B + +Creates the configuration folder for the default system. + +The resulting folder will be named C and will be created +in the IC-folder (usually +C). + +Within that folder, two subfolders, C and C will be created. + +In the C-subfolder, two files will be created: C +and C, who are empty stub-scripts meant to be edited by the +OpenSLX admin. + +The functions returns 1 if any folder or file had to be created and 0 if all the +required folders & files already existed. + +=cut + +sub createConfigFolderForDefaultSystem +{ + my $result = 0; + my $defaultConfigPath = "$openslxConfig{'private-path'}/config/default"; + if (!-e "$defaultConfigPath/initramfs") { + slxsystem("mkdir -p $defaultConfigPath/initramfs"); + $result = 1; + } + if (!-e "$defaultConfigPath/rootfs") { + slxsystem("mkdir -p $defaultConfigPath/rootfs"); + $result = 1; + } + + # create default pre-/postinit scripts for us in initramfs: + my $preInitFile = "$defaultConfigPath/initramfs/preinit.local"; + if (!-e $preInitFile) { + my $preInit = unshiftHereDoc(<<' END-of-HERE'); + #!/bin/sh + # + # This script allows the local admin to extend the + # capabilities at the beginning of the initramfs (stage3). + # The toolset is rather limited and you have to keep in mind + # that stage4 rootfs has the prefix '/mnt'. + END-of-HERE + spitFile($preInitFile, $preInit); + slxsystem("chmod u+x $preInitFile"); + $result = 1; + } + + my $postInitFile = "$defaultConfigPath/initramfs/postinit.local"; + if (!-e $postInitFile) { + my $postInit = unshiftHereDoc(<<' END-of-HERE'); + #!/bin/sh + # + # This script allows the local admin to extend the + # capabilities at the end of the initramfs (stage3). + # The toolset is rather limited and you have to keep in mind + # that stage4 rootfs has the prefix '/mnt'. + # But you may use some special slx-functions available via + # inclusion: '. /etc/functions' ... + END-of-HERE + spitFile($postInitFile, $postInit); + slxsystem("chmod u+x $postInitFile"); + $result = 1; + } + return $result; +} + +=item B + +Creates the configuration folder for the system whose name has been given in +I<$systemName>. + +The resulting folder will be named just like the system and will be created +in the IC-folder (usually +C). + +In that folder, a single subfolder C will be created (representing +the default setup for all clients of that system). Within that folder, two +subfolders, C and C will be created. + +The functions returns 1 if any folder had to be created and 0 if all the +required folders already existed. + +=cut + +sub createConfigFolderForSystem +{ + my $systemName = shift || confess "need to pass in system-name!"; + + my $result = 0; + my $systemConfigPath + = "$openslxConfig{'private-path'}/config/$systemName/default"; + if (!-e "$systemConfigPath/initramfs") { + slxsystem("mkdir -p $systemConfigPath/initramfs"); + $result = 1; + } + if (!-e "$systemConfigPath/rootfs") { + slxsystem("mkdir -p $systemConfigPath/rootfs"); + $result = 1; + } + return $result; +} + +=back + +=cut + +1; diff --git a/src/lib/OpenSLX/DistroUtils.pm b/src/lib/OpenSLX/DistroUtils.pm new file mode 100644 index 00000000..d7456d92 --- /dev/null +++ b/src/lib/OpenSLX/DistroUtils.pm @@ -0,0 +1,90 @@ +# Copyright (c) 2008, 2009 - 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/ +# ----------------------------------------------------------------------------- +# DistroUtils.pm +# - provides utility distro based functions for OpenSLX +# ----------------------------------------------------------------------------- +package OpenSLX::DistroUtils; + +use strict; +use warnings; + +use OpenSLX::Utils; +use OpenSLX::Basics; + +use Data::Dumper; + +use OpenSLX::DistroUtils::Engine; +use OpenSLX::DistroUtils::InitFile; + +use Exporter; + +use vars qw(@ISA @EXPORT $VERSION); + +use Exporter; +$VERSION = 1.01; +@ISA = qw(Exporter); + +@EXPORT = qw( + newInitFile + getInitFileForDistro + simpleInitFile + getKernelVersionForDistro +); + + + +sub newInitFile { + return OpenSLX::DistroUtils::InitFile->new(); +} + + +sub simpleInitFile { + my $config = shift; + my $initFile = OpenSLX::DistroUtils::InitFile->new(); + + return $initFile->simpleSetup($config); +} + + +sub getInitFileForDistro { + my $initFile = shift; + my $distroName = shift; + my $distro; + + my $engine = OpenSLX::DistroUtils::Engine->new(); + + if ($distroName) { + $distro = $engine->loadDistro($distroName); + } else { + $distro = $engine->loadDistro('Base'); + } + + #return $distro->dumpInit($initFile); + return $distro->generateInitFile($initFile); +} + +sub getKernelVersionForDistro { + my $kernelPath = shift; + my $distroName = shift; + my $distro; + + my $engine = OpenSLX::DistroUtils::Engine->new(); + + if ($distroName) { + $distro = $engine->loadDistro($distroName); + } else { + $distro = $engine->loadDistro('Base'); + } + + return $distro->getKernelVersion($kernelPath); +} + +1; \ No newline at end of file diff --git a/src/lib/OpenSLX/DistroUtils/Base.pm b/src/lib/OpenSLX/DistroUtils/Base.pm new file mode 100644 index 00000000..f9e6b13b --- /dev/null +++ b/src/lib/OpenSLX/DistroUtils/Base.pm @@ -0,0 +1,429 @@ +# Copyright (c) 2008, 2009 - 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/ +# ----------------------------------------------------------------------------- +# DistroUtils.pm +# - provides base for distro based utils for OpenSLX +# ----------------------------------------------------------------------------- +package OpenSLX::DistroUtils::Base; + +use Data::Dumper; +use OpenSLX::Utils; +use Clone qw(clone); +use Switch; + +use strict; +use warnings; + +sub new +{ + my $class = shift; + my $self = {}; + return bless $self, $class; +} + +sub dumpInit +{ + my $self = shift; + my $initFile = shift; + + print Dumper($initFile->{'configHash'}); + + print $self->generateInitFile($initFile); +} + +sub _concatContent +{ + my $self = shift; + my $block = shift; + + my $output; + + $output = "#"; + $output .= $block->{'blockDesc'}; + $output .= "\n"; + + my $content = $block->{'content'}; + while ( my ($priority, $contentArray) = each %$content ) + { + $output .= join("\n", @$contentArray); + $output .= "\n"; + } + + return $output; +} + +sub _renderInfoBlock +{ + my $self = shift; + my $config = shift; + + my $tpl = unshiftHereDoc(<<' End-of-Here'); + ### BEGIN INIT INFO + # Provides: %s + # Required-Start: %s + # Required-Stop: %s + # Default-Start: %s + # Default-Stop: %s + # Short-Description: %s + ### END INIT INFO + + End-of-Here + + return sprintf( + $tpl, + $config->{'name'}, + $config->{'requiredStart'}, + $config->{'requiredStop'}, + $config->{'defaultStart'}, + $config->{'defaultStop'}, + $config->{'shortDesc'} + ); +} + +sub _insertSystemHelperFunctions +{ + my $self = shift; + my $content = shift; + + # do some regex + + # ubuntu: + # log_end_msg + # log_progress_msg + # log_daemon_msg + # log_action_msg + + # start-stop-daemon + + # suse http://de.opensuse.org/Paketbau/SUSE-Paketkonventionen/Init-Skripte + + return $content; +} + +sub _renderHighlevelConfig +{ + my $self = shift; + my $initFile = shift; + + my $element; + my $hlc = $initFile->{'configHash'}->{'highlevelConfig'}; + + while ( $element = shift(@$hlc)){ + switch ($element->{type}) { + case 'daemon' { + my $tpl; + $tpl = "%s_BIN=%s \n"; + $tpl .= "[ -x %s_BIN ] || exit 5\n\n"; + $tpl .= "%s_OPTS=\"%s\" \n"; + $tpl .= "[ -f /etc/sysconfig/%s ] . /etc/sysconfig/%s \n\n"; + $tpl .= "[ -f /etc/default/%s ] . /etc/default/%s \n\n"; + $tpl .= "%s_PIDFILE=\"/var/run/%s.init.pid\" \n\n"; + $initFile->addToBlock('head', + sprintf( + $tpl, + uc($element->{shortname}), + $element->{binary}, + uc($element->{shortname}), + uc($element->{shortname}), + $element->{parameters}, + $element->{shortname}, + $element->{shortname}, + $element->{shortname}, + $element->{shortname}, + uc($element->{shortname}), + $element->{shortname} + ), + $element->{priority} + ); + + $tpl = "echo -n \"Starting %s \"\n"; + $tpl .= "startproc -f -p \$%s_PIDFILE \$%s_BIN \$%s_OPTS\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('start', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}), + uc($element->{shortname}) + ), + $element->{priority} + ); + + $tpl = "echo -n \"Shutting down %s\" \n"; + $tpl .= "killproc -p \$%s_PIDFILE -TERM \$%s_BIN\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('stop', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}) + ), + 10 - $element->{priority} + ); + + $tpl = "## Stop the service and if this succeeds (i.e. the \n"; + $tpl .= "## service was running before), start it again.\n"; + $tpl .= "\$0 status >/dev/null && \$0 restart\n\n"; + $tpl .= "# Remember status and be quiet\n"; + $tpl .= "rc_status"; + $initFile->addToCase('try-restart', + $tpl, + $element->{priority} + ); + + $tpl = "## Stop the service and regardless of whether it was \n"; + $tpl .= "## running or not, start it again.\n"; + $tpl .= "\$0 stop\n"; + $tpl .= "\$0 start\n\n"; + $tpl .= "# Remember status and be quiet\n"; + $tpl .= "rc_status"; + $initFile->addToCase('restart', + $tpl, + $element->{priority} + ); + + $tpl = "echo -n \"Reload service %s\"\n"; + $tpl .= "killproc -p \$%s_PIDFILE -HUP \$%s_BIN\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('reload', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}), + uc($element->{shortname}) + ), + $element->{priority} + ); + + $tpl = "echo -n \"Checking for service %s\"\n"; + $tpl .= "checkproc -p \$%s_PIDFILE \$%s_BIN\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('status', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}) + ), + $element->{priority} + ); + + + } + case 'function' { + my $tpl; + $tpl = "%s () { \n"; + $tpl .= "%s"; + $tpl .= "\n}\n"; + $initFile->addToBlock('functions', + sprintf( + $tpl, + $element->{name}, + $element->{script} + ) + ); + + } + case 'functionCall' { + my $tpl; + $tpl = "%s %s\n"; + #$tpl .= "%s\n "; + $initFile->addToCase($element->{block}, + sprintf( + $tpl, + $element->{function}, + $element->{parameters}, + "" + ), + $element->{priority} + ); + + } + } + } + +} + + +sub _getInitsystemIncludes +{ + return "\n"; +} + +sub _renderCasePrefix +{ + return "\n"; +} + +sub _renderFooter +{ + return "exit 0\n"; +} + +sub _generateUsage +{ + my $self = shift; + my $usage = shift; + my $tpl; + + $tpl = "## print out usage \n"; + $tpl .= "echo \"Usage: \$0 {%s}\" >&2 \n"; + $tpl .= "exit 1"; + + return sprintf( + $tpl, + $usage + ); +} + +sub _getAuthorBlock +{ + my $tpl; + + $tpl = "# Copyright (c) 2009 - OpenSLX GmbH \n"; + $tpl .= "# \n"; + $tpl .= "# This program is free software distributed under the GPL version 2. \n"; + $tpl .= "# See http://openslx.org/COPYING \n"; + $tpl .= "# \n"; + $tpl .= "# If you have any feedback please consult http://openslx.org/feedback and \n"; + $tpl .= "# send your suggestions, praise, or complaints to feedback\@openslx.org \n"; + $tpl .= "# \n"; + $tpl .= "# General information about OpenSLX can be found at http://openslx.org/ \n"; + $tpl .= "# -----------------------------------------------------------------------------\n"; + $tpl .= "# §filename§ \n"; + $tpl .= "# - §desc§ \n"; + $tpl .= "# §generated§ \n"; + $tpl .= "# -----------------------------------------------------------------------------\n\n"; + + return sprintf( + $tpl + ); +} + +sub generateInitFile +{ + my $self = shift; + my $initFile = shift; + my $content; + my @usage; + + # get a copy of initFile object before modifying it.. + my $initFileCopy = clone($initFile); + + $self->_renderHighlevelConfig($initFileCopy); + + my $config = $initFileCopy->{'configHash'}; + my $output; + + # head + $output = "#!/bin/sh\n"; + $output .= $self->_getAuthorBlock(); + $output .= $self->_renderInfoBlock($config); + $output .= $self->_getInitsystemIncludes(); + + if (keys(%{$config->{'blocks'}->{'head'}->{'content'}}) > 0) { + $output .= $self->_concatContent($config->{'blocks'}->{'head'}); + } + + # functions + if (keys(%{$config->{'blocks'}->{'functions'}->{'content'}}) > 0) { + $output .= $self->_concatContent($config->{'blocks'}->{'functions'}); + } + + # case block + $output .= $self->_renderCasePrefix(); + $output .= "\ncase \"\$1\" in \n"; + + # get caseBlocks in defined order + my @blocks = sort{ + $config->{'caseBlocks'}->{$a}->{'order'} <=> + $config->{'caseBlocks'}->{$b}->{'order'} + } + keys(%{$config->{'caseBlocks'}}); + + # case block + while (@blocks) + { + my $block= shift(@blocks); + if (keys(%{$config->{'caseBlocks'}->{$block}->{'content'}}) > 0) { + push(@usage, $block); + $output .= " $block)\n"; + $content = $self->_concatContent($config->{'caseBlocks'}->{$block}); + $content =~ s/^/ /mg; + $output .= $content; + $output .= " ;;\n"; + } else { + if ($config->{'caseBlocks'}->{$block}->{'required'}) { + print "required block $block undefined"; + } + } + } + + # autogenerate usage + if (scalar(grep(/usage/, @usage)) == 0) { + $initFileCopy->addToCase( + 'usage', + $self->_generateUsage(join(', ',@usage)) + ); + + $output .= " *)\n"; + $content = $self->_concatContent($config->{'caseBlocks'}->{'usage'}); + $content =~ s/^/ /mg; + $output .= $content; + $output .= " ;;\n"; + + } + + # footer + $output .= "esac\n\n"; + $output .= $self->_renderFooter(); + + return $output; + +} + +sub getKernelVersion +{ + my $self = shift; + my $kernelPath = shift; + + + my $newestKernelFile; + my $newestKernelFileSortKey = ''; + my $kernelPattern = '{vmlinuz,kernel-genkernel-x86}-*'; + foreach my $kernelFile (glob("$kernelPath/$kernelPattern")) { + next unless $kernelFile =~ m{ + (?:vmlinuz|x86)-(\d+)\.(\d+)\.(\d+)(?:\.(\d+))?-(\d+(?:\.\d+)?) + }x; + my $sortKey + = sprintf("%02d.%02d.%02d.%02d-%2.1f", $1, $2, $3, $4||0, $5); + if ($newestKernelFileSortKey lt $sortKey) { + $newestKernelFile = $kernelFile; + $newestKernelFileSortKey = $sortKey; + } + } + + if (!defined $newestKernelFile) { + die; #_tr("unable to pick a kernel-file from path '%s'!", $kernelPath); + } + + $newestKernelFile =~ /.*?-([.\-0-9]*)-([a-zA-Z]*?)$/; + my $kernel = {}; + $kernel->{'version'} = $1; + $kernel->{'suffix'} = $2; + return $kernel; + +} + + +1; diff --git a/src/lib/OpenSLX/DistroUtils/Engine.pm b/src/lib/OpenSLX/DistroUtils/Engine.pm new file mode 100644 index 00000000..16c3e585 --- /dev/null +++ b/src/lib/OpenSLX/DistroUtils/Engine.pm @@ -0,0 +1,58 @@ +# Copyright (c) 2008, 2009 - 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/ +# ----------------------------------------------------------------------------- +# Engine.pm +# - provides engine to distro based utils for OpenSLX +# ----------------------------------------------------------------------------- +package OpenSLX::DistroUtils::Engine; + +use OpenSLX::Basics; + +use strict; +use warnings; + +sub new +{ + my $class = shift; + my $self = {}; + return bless $self, $class; +} + + +sub loadDistro { + my $self = shift; + my $distroName = shift; + $distroName = ucfirst($distroName); + + my $distro; + + my $loaded = eval { + $distro = instantiateClass("OpenSLX::DistroUtils::${distroName}"); + return 0 if !$distro; # module does not exist, try next + 1; + }; + + if (!$loaded) { + vlog(1, "can't find distro specific class, try base class.."); + $loaded = eval { + $distro = instantiateClass("OpenSLX::DistroUtils::Base"); + return 0 if !$distro; # module does not exist, try next + 1; + }; + } + + if (!$loaded) { + vlog(1, "failed to load DistroUtils!"); + } + + return $distro; +} + +1; diff --git a/src/lib/OpenSLX/DistroUtils/InitFile.pm b/src/lib/OpenSLX/DistroUtils/InitFile.pm new file mode 100644 index 00000000..ab729959 --- /dev/null +++ b/src/lib/OpenSLX/DistroUtils/InitFile.pm @@ -0,0 +1,232 @@ +# Copyright (c) 2008, 2009 - 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/ +# ----------------------------------------------------------------------------- +# InitFile.pm +# - configuration object for runlevel script +# ----------------------------------------------------------------------------- +package OpenSLX::DistroUtils::InitFile; + +use strict; +use warnings; + +use OpenSLX::Basics; +use OpenSLX::Utils; + +sub new { + my $class = shift; + my $params = shift || {}; + my $self = { + }; + + $self->{'configHash'} = _initialConfigHash(); + + return bless $self, $class; +} + +sub _initialConfigHash() { + return { + 'name' => "", + 'requiredStart' => "\$remote_fs", + 'requiredStop' => "\$remote_fs", + 'defaultStart' => "2 3 4 5", + 'defaultStop' => "1", + 'shortDesc' => "", + 'blocks' => { + 'head' => { + 'blockDesc' => "head: file existing checks, etc.", + 'content' => {} + }, + 'functions' => { + 'blockDesc' => "functions: helper functions", + 'content' => {} + } + }, + 'caseBlocks' => { + 'start' => { + 'blockDesc' => "start: defines start function for initscript", + 'content' => {}, + 'order' => 1, + 'required' => 1 + }, + 'stop' => { + 'blockDesc' => "stop: defines stop function for initscript", + 'content' => {}, + 'order' => 2, + 'required' => 1 + }, + 'reload' => { + 'blockDesc' => "reload: defines reload function for initscript", + 'content' => {}, + 'order' => 3, + 'required' => 0 + }, + 'force-reload' => { + 'blockDesc' => "force-reload: defines force-reload function for initscript", + 'content' => {}, + 'order' => 4, + 'required' => 0 + }, + 'restart' => { + 'blockDesc' => "restart: defines restart function for initscript", + 'content' => {}, + 'order' => 5, + 'required' => 1 + }, + 'try-restart' => { + 'blockDesc' => "restart: defines restart function for initscript", + 'content' => {}, + 'order' => 6, + 'required' => 0 + }, + 'status' => { + 'blockDesc' => "status: defines status function for initscript", + 'content' => {}, + 'order' => 7, + 'required' => 0 + }, + 'usage' => { + 'blockDesc' => "usage: defines usage function for initscript", + 'content' => {}, + 'order' => 8, + 'required' => 0 + } + } + }; +} + +sub addToCase { + my $self = shift; + my $blockName = shift; + my $content = shift; + my $priority = shift || 5; + + #check if block is valid.. + + push(@{$self->{'configHash'}->{'caseBlocks'}->{$blockName}->{'content'}->{$priority}}, $content); + + return $self; +} + +sub addToBlock { + my $self = shift; + my $blockName = shift; + my $content = shift; + my $priority = shift || 5; + + #check if block is valid.. + + push(@{$self->{'configHash'}->{'blocks'}->{$blockName}->{'content'}->{$priority}}, $content); + + return $self; +} + +sub setName { + my $self = shift; + my $name = shift; + + $self->{'configHash'}->{'name'} = $name; + return $self; +} + +sub setDesc { + my $self = shift; + my $desc = shift; + + $self->{'configHash'}->{'shortDesc'} = $desc; + return $self; +} + +sub addFunction { + my $self = shift; + my $name = shift; + my $script = shift; + my $flags = shift || {}; + my $priority = $flags->{priority} || 5; + + push(@{$self->{'configHash'}->{'highlevelConfig'}}, + { + name => $name, + script => $script, + priority => $priority, + type => 'function' + }); + return 1; +} + +sub addFunctionCall { + my $self = shift; + my $function = shift; + my $block = shift; + my $flags = shift; + my $priority = $flags->{priority} || 5; + my $parameters = $flags->{parameters} || ""; + + push(@{$self->{'configHash'}->{'highlevelConfig'}}, + { + function => $function, + block => $block, + parameters => $parameters, + priority => $priority, + type => 'functionCall' + }); + return 1; +} + +sub addScript { + my $self = shift; + my $name = shift; + my $script = shift; + my $flags = shift || {}; + my $block = $flags->{block} || 'start'; + my $required = $flags->{required} || 1; + my $errormsg = $flags->{errormsg} || "$name failed!"; + my $priority = $flags->{priority} || 5; + + push(@{$self->{'configHash'}->{'highlevelConfig'}}, + { + name => $name, + script => $script, + block => $block, + required => $required, + priority => $priority, + errormsg => $errormsg, + type => 'script' + }); + return 1; +} + +sub addDaemon { + my $self = shift; + my $binary = shift; + $binary =~ m/\/([^\/]*)$/; + my $shortname = $1; + my $parameters = shift || ""; + my $flags = shift || {}; + my $required = $flags->{required} || 1; + my $desc = $flags->{desc} || "$shortname"; + my $errormsg = $flags->{errormsg} || "$desc failed!"; + my $priority = $flags->{priority} || 5; + + push(@{$self->{'configHash'}->{'highlevelConfig'}}, + { + binary => $binary, + shortname => $shortname, + parameters => $parameters, + desc => $desc, + errormsg => $errormsg, + required => $required, + priority => $priority, + type => 'daemon' + }); + return 1; +} + + +1; diff --git a/src/lib/OpenSLX/DistroUtils/Suse.pm b/src/lib/OpenSLX/DistroUtils/Suse.pm new file mode 100644 index 00000000..8a41c2eb --- /dev/null +++ b/src/lib/OpenSLX/DistroUtils/Suse.pm @@ -0,0 +1,174 @@ +# Copyright (c) 2008, 2009 - 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/ +# ----------------------------------------------------------------------------- +# Suse.pm +# - provides suse specific functions for distro based utils for OpenSLX +# ----------------------------------------------------------------------------- +package OpenSLX::DistroUtils::Suse; + +use strict; +use warnings; +use Switch; + +use base qw(OpenSLX::DistroUtils::Base); + + +sub _renderCasePrefix +{ + return "rc_reset\n"; +} + +sub _renderFooter +{ + return "rc_exit\n"; +} + + +sub _renderHighlevelConfig { + my $self = shift; + my $initFile = shift; + + my $element; + my $hlc = $initFile->{'configHash'}->{'highlevelConfig'}; + + while ( $element = shift(@$hlc)){ + switch ($element->{type}) { + case 'daemon' { + my $tpl; + $tpl = "%s_BIN=%s \n"; + $tpl .= "[ -x %s_BIN ] || exit 5\n\n"; + $tpl .= "%s_OPTS=\"%s\" \n"; + $tpl .= "[ -f /etc/sysconfig/%s ] . /etc/sysconfig/%s \n\n"; + $tpl .= "%s_PIDFILE=\"/var/run/%s.init.pid\" \n\n"; + $initFile->addToBlock('head', + sprintf( + $tpl, + uc($element->{shortname}), + $element->{binary}, + uc($element->{shortname}), + uc($element->{shortname}), + $element->{parameters}, + $element->{shortname}, + $element->{shortname}, + uc($element->{shortname}), + $element->{shortname} + ) + ); + + $tpl = "echo -n \"Starting %s \"\n"; + $tpl .= "startproc -f -p \$%s_PIDFILE \$%s_BIN \$%s_OPTS\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('start', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}), + uc($element->{shortname}) + ) + ); + + $tpl = "echo -n \"Shutting down %s\" \n"; + $tpl .= "killproc -p \$%s_PIDFILE -TERM \$%s_BIN\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('stop', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}) + ) + ); + + $tpl = "## Stop the service and if this succeeds (i.e. the \n"; + $tpl .= "## service was running before), start it again.\n"; + $tpl .= "\$0 status >/dev/null && \$0 restart\n\n"; + $tpl .= "# Remember status and be quiet\n"; + $tpl .= "rc_status"; + $initFile->addToCase('try-restart', + $tpl + ); + + $tpl = "## Stop the service and regardless of whether it was \n"; + $tpl .= "## running or not, start it again.\n"; + $tpl .= "\$0 stop\n"; + $tpl .= "\$0 start\n\n"; + $tpl .= "# Remember status and be quiet\n"; + $tpl .= "rc_status"; + $initFile->addToCase('restart', + $tpl + ); + + $tpl = "echo -n \"Reload service %s\"\n"; + $tpl .= "killproc -p \$%s_PIDFILE -HUP \$%s_BIN\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('reload', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}), + uc($element->{shortname}) + ) + ); + + $tpl = "echo -n \"Checking for service %s\"\n"; + $tpl .= "checkproc -p \$%s_PIDFILE \$%s_BIN\n"; + $tpl .= "rc_status -v"; + $initFile->addToCase('status', + sprintf( + $tpl, + $element->{desc}, + uc($element->{shortname}), + uc($element->{shortname}) + ) + ); + + + } + case 'function' { + my $tpl; + $tpl = "%s () { \n"; + $tpl .= "%s"; + $tpl .= "\n}\n"; + $initFile->addToBlock('functions', + sprintf( + $tpl, + $element->{name}, + $element->{script} + ) + ); + + } + case 'functionCall' { + my $tpl; + $tpl = "%s %s\n"; + #$tpl .= "%s\n "; + $initFile->addToCase($element->{block}, + sprintf( + $tpl, + $element->{function}, + $element->{parameters}, + "" + ), + $element->{priority} + ); + + } + } + } +} + +sub _getInitsystemIncludes +{ + return ". /etc/rc.status\n\n"; +} + +1; \ No newline at end of file diff --git a/src/lib/OpenSLX/DistroUtils/Ubuntu.pm b/src/lib/OpenSLX/DistroUtils/Ubuntu.pm new file mode 100644 index 00000000..915c19c6 --- /dev/null +++ b/src/lib/OpenSLX/DistroUtils/Ubuntu.pm @@ -0,0 +1,172 @@ +# Copyright (c) 2008, 2009 - 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/ +# ----------------------------------------------------------------------------- +# Ubuntu.pm +# - provides ubuntu specific functions for distro based utils for OpenSLX +# ----------------------------------------------------------------------------- +package OpenSLX::DistroUtils::Ubuntu; + +use strict; +use warnings; +use Switch; + +use base qw(OpenSLX::DistroUtils::Base); + +sub _getInitsystemIncludes +{ + return ". /lib/lsb/init-functions\n\n"; +} + +sub _renderCasePrefix +{ + return ""; +} + +sub _renderFooter +{ + return "exit 0\n"; +} + + +sub _renderHighlevelConfig { + my $self = shift; + my $initFile = shift; + + my $element; + my $hlc = $initFile->{'configHash'}->{'highlevelConfig'}; + + while ( $element = shift(@$hlc)){ + switch ($element->{type}) { + case 'daemon' { + $element->{binary} =~ m/\/([^\/]*)$/; + my $shortname = $1; + my $tpl = "export %s_PARAMS=\"%s\" \n"; + $tpl .= "if [ -f /etc/default/%s ]; then . /etc/default/%s; fi \n"; + $initFile->addToBlock('head', + sprintf( + $tpl, + uc($shortname), + $element->{parameters}, + $shortname, + $shortname + ) + ); + + + $tpl = "log_daemon_msg \"Starting %s\" \"%s\" \n"; + $tpl .= "start-stop-daemon --start --quiet --oknodo "; + $tpl .= "--pidfile /var/run/%s.pid --exec %s -- \$%s_PARAMS \n"; + $tpl .= "log_end_msg \$?"; + $initFile->addToCase('start', + sprintf( + $tpl, + $element->{description}, + $shortname, + $shortname, + $element->{binary}, + uc($shortname) + ) + ); + + $tpl = "start-stop-daemon --stop --quiet --oknodo "; + $tpl .= "--pidfile /var/run/%s.pid \n"; + $tpl .= "log_end_msg \$?"; + $initFile->addToCase('stop', + sprintf( + $tpl, + $shortname + ) + ); + + $tpl = "log_daemon_msg \"Restarting %s\" \"%s\"\n"; + $tpl .= "\$0 stop\n"; + $tpl .= "case \"\$?\" in\n"; + $tpl .= " 0|1)\n"; + $tpl .= " \$0 start\n"; + $tpl .= " case \"\$?\" in\n"; + $tpl .= " 0) log_end_msg 0 ;;\n"; + $tpl .= " 1) log_end_msg 1 ;; # Old process is still running\n"; + $tpl .= " *) log_end_msg 1 ;; # Failed to start\n"; + $tpl .= " esac\n"; + $tpl .= " ;;\n"; + $tpl .= " *)\n"; + $tpl .= " # Failed to stop\n"; + $tpl .= " log_end_msg 1\n"; + $tpl .= " ;;\n"; + $tpl .= "esac\n"; + $tpl .= ";;\n"; + + $initFile->addToCase('restart', + sprintf( + $tpl, + $shortname + ) + ); + + + $tpl = "start-stop-daemon --stop --signal 1 --quiet "; + $tpl .= "--pidfile /var/run/%s.pid --name \$s\n"; + $tpl .= "return 0\n"; + $initFile->addToCase('reload', + sprintf( + $tpl, + $shortname, + $element->{binary} + ) + ); + + $tpl = "status_of_proc -p /var/run/%s.pid %s_BIN %s && exit 0 || exit \$?"; + $initFile->addToCase('status', + sprintf( + $tpl, + $element->{shortname}, + $element->{binary}, + $element->{shortname} + ) + ); + + + } + case 'function' { + my $tpl; + $tpl = "%s () { \n"; + $tpl .= "%s"; + $tpl .= "\n}\n"; + $initFile->addToBlock('functions', + sprintf( + $tpl, + $element->{name}, + $element->{script} + ) + ); + + } + case 'functionCall' { + my $tpl; + $tpl = "%s %s\n"; + #$tpl .= "%s\n "; + $initFile->addToCase($element->{block}, + sprintf( + $tpl, + $element->{function}, + $element->{parameters}, + "" + ), + $element->{priority} + ); + + } + + } + } + +} + +1; \ No newline at end of file diff --git a/src/lib/OpenSLX/LibScanner.pm b/src/lib/OpenSLX/LibScanner.pm new file mode 100644 index 00000000..e1f42ba4 --- /dev/null +++ b/src/lib/OpenSLX/LibScanner.pm @@ -0,0 +1,262 @@ +# Copyright (c) 2006-2008 - 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/ +# ----------------------------------------------------------------------------- +# LibScanner.pm +# - module that recursively scans a given binary for library dependencies +# ----------------------------------------------------------------------------- +package OpenSLX::LibScanner; + +use strict; +use warnings; + +use File::Find; +use File::Path; + +use OpenSLX::Basics; +use OpenSLX::Utils; + +################################################################################ +### interface methods +################################################################################ +sub new +{ + my $class = shift; + my $params = shift || {}; + + checkParams($params, { + 'root-path' => '!', + 'verbose' => '?', + } ); + + my $self = { + rootPath => $params->{'root-path'}, + verbose => $params->{'verbose'} || 0, + }; + + return bless $self, $class; +} + +sub determineRequiredLibs +{ + my $self = shift; + my @binaries = @_; + + $self->{filesToDo} = []; + $self->{libs} = []; + $self->{libInfo} = {}; + + $self->_fetchLoaderConfig(); + + foreach my $binary (@binaries) { + if (substr($binary, 0, 1) ne '/') { + # force relative paths relative to $rootPath: + $binary = "$self->{rootPath}/$binary"; + } + if (!-e $binary) { + warn _tr("$0: unable to find file '%s', skipping it\n", $binary); + next; + } + push @{$self->{filesToDo}}, $binary; + } + + foreach my $file (@{$self->{filesToDo}}) { + $self->_addLibsForBinary($file); + } + + return @{$self->{libs}}; +} + +sub _fetchLoaderConfig +{ + my $self = shift; + + my @libFolders; + + if (!-e "$self->{rootPath}/etc") { + die _tr("'%s'-folder not found, maybe wrong root-path?\n", + "$self->{rootPath}/etc"); + } + $self->_fetchLoaderConfigFile("$self->{rootPath}/etc/ld.so.conf"); + + # add "trusted" folders /lib and /usr/lib if not already in place: + if (!grep { m[^$self->{rootPath}/lib$] } @libFolders) { + push @libFolders, "$self->{rootPath}/lib"; + } + if (!grep { m[^$self->{rootPath}/usr/lib$] } @libFolders) { + push @libFolders, "$self->{rootPath}/usr/lib"; + } + + # add lib32-folders for 64-bit Debians, as they do not + # refer those in ld.so.conf (which I find strange...) + if (-e '/lib32' && !grep { m[^$self->{rootPath}/lib32$] } @libFolders) { + push @libFolders, "$self->{rootPath}/lib32"; + } + if (-e '/usr/lib32' + && !grep { m[^$self->{rootPath}/usr/lib32$] } @libFolders) + { + push @libFolders, "$self->{rootPath}/usr/lib32"; + } + + push @{$self->{libFolders}}, @libFolders; + + return; +} + +sub _fetchLoaderConfigFile +{ + my $self = shift; + my $ldConfFile = shift; + + return unless -e $ldConfFile; + my $ldconfFH; + if (!open($ldconfFH, '<', $ldConfFile)) { + warn(_tr("unable to open file '%s' (%s)", $ldConfFile, $!)); + return; + } + while (<$ldconfFH>) { + chomp; + if (m{^\s*include\s+(.+?)\s*$}i) { + my @incFiles = glob("$self->{rootPath}$1"); + foreach my $incFile (@incFiles) { + if ($incFile) { + $self->_fetchLoaderConfigFile($incFile); + } + } + next; + } + if (m{\S+}i) { + s[=.+][]; + # remove any lib-type specifications (e.g. '=libc5') + push @{$self->{libFolders}}, "$self->{rootPath}$_"; + } + } + close $ldconfFH + or die(_tr("unable to close file '%s' (%s)", $ldConfFile, $!)); + return; +} + +sub _addLibsForBinary +{ + my $self = shift; + my $binary = shift; + + # first do some checks: + warn _tr("analyzing '%s'...\n", $binary) if $self->{verbose}; + my $fileInfo = `file --dereference --brief --mime $binary 2>/dev/null`; + if ($?) { + die _tr("unable to fetch file info for '%s', giving up!\n", $binary); + } + chomp $fileInfo; + warn _tr("\tinfo is: '%s'...\n", $fileInfo) if $self->{verbose}; + if ($fileInfo !~ m[^application/(x-executable|x-shared)]i) { + # ignore anything that's not an executable or a shared library + warn _tr( + "%s: ignored, as it isn't an executable or a shared library\n", + $binary + ); + next; + } + + # fetch file info again, this time without '--mime' in order to get the architecture + # bitwidth: + $fileInfo = `file --dereference --brief $binary 2>/dev/null`; + if ($?) { + die _tr("unable to fetch file info for '%s', giving up!\n", $binary); + } + chomp $fileInfo; + warn _tr("\tinfo is: '%s'...\n", $fileInfo) if $self->{verbose}; + my $bitwidth = ($fileInfo =~ m[64-bit]i) ? 64 : 32; + # determine whether binary is 32- or 64-bit platform + + # now find out about needed libs, we first try objdump... + warn _tr("\ttrying objdump...\n") if $self->{verbose}; + my $res = `objdump -p $binary 2>/dev/null`; + if (!$?) { + # find out if rpath is set for binary: + my $rpath; + if ($res =~ m[^\s*RPATH\s*(\S+)]im) { + $rpath = $1; + warn _tr("\trpath='%s'\n", $rpath) if $self->{verbose}; + } + while ($res =~ m[^\s*NEEDED\s*(.+?)\s*$]gm) { + $self->_addLib($1, $bitwidth, $rpath); + } + } else { + # ...objdump failed, so we try readelf instead: + warn _tr("\ttrying readelf...\n") if $self->{verbose}; + $res = `readelf -d $binary 2>/dev/null`; + if ($?) { + die _tr( + "neither objdump nor readelf seems to be installed, giving up!\n" + ); + } + # find out if rpath is set for binary: + my $rpath; + if ($res =~ m{Library\s*rpath:\s*\[([^\]]+)}im) { + $rpath = $1; + warn _tr("\trpath='%s'\n", $rpath) if $self->{verbose}; + } + while ($res =~ m{\(NEEDED\)[^\[]+\[(.+?)\]\s*$}gm) { + $self->_addLib($1, $bitwidth, $rpath); + } + } + return; +} + +sub _addLib +{ + my $self = shift; + my $lib = shift; + my $bitwidth = shift; + my $rpath = shift; + + if (!exists $self->{libInfo}->{$lib}) { + my $libPath; + my @folders = @{$self->{libFolders}}; + if (defined $rpath) { + # add rpath if given (explicit paths set during link stage) + push @folders, split ':', $rpath; + } + foreach my $folder (@folders) { + if (-e "$folder/$lib") { + # have library matching name, now check if the platform is ok, too: + my $libFileInfo = + `file --dereference --brief $folder/$lib 2>/dev/null`; + if ($?) { + die _tr("unable to fetch file info for '%s', giving up!\n", + $folder / $lib); + } + my $libBitwidth = ($libFileInfo =~ m[64-bit]i) ? 64 : 32; + if ($bitwidth != $libBitwidth) { + vlog( + 0, + _tr( + '%s has wrong bitwidth (%s instead of %s)', + "$folder/$lib", $libBitwidth, $bitwidth + ) + ) if $self->{verbose}; + next; + } + $libPath = "$folder/$lib"; + last; + } + } + if (!defined $libPath) { + die _tr("unable to find lib %s!\n", $lib); + } + print "found $libPath\n" if $self->{verbose}; + push @{$self->{libs}}, $libPath; + $self->{libInfo}->{$lib} = 1; + push @{$self->{filesToDo}}, $libPath; + } + return; +} + +1; diff --git a/src/lib/OpenSLX/ScopedResource.pm b/src/lib/OpenSLX/ScopedResource.pm new file mode 100644 index 00000000..af912691 --- /dev/null +++ b/src/lib/OpenSLX/ScopedResource.pm @@ -0,0 +1,174 @@ +# Copyright (c) 2008 - 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::ScopedResource; + +use strict; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version + +=head1 NAME + +OpenSLX::ScopedResource - provides a helper class that implements the +'resource-acquisition-by-definition' pattern. + +=head1 SYNOPSIS + +{ # some scope + + my $distroSession = OpenSLX::ScopedResource->new({ + name => 'distro::session', + acquire => sub { $distro->startSession(); 1 }, + release => sub { $distro->finishSession(); 1 }, + }); + + die $@ if ! eval { + # do something dangerous and unpredictable here: + doRandomStuff(); + 1; + }; + +} +# the distro-session will be cleanly finished, no matter if we died or not + +=head1 DESCRIPTION + +The class C wraps any resource such that the resource will be +acquired when an object of this class is created. Whenever the ScopedResource +object is being destroyed (e.g. by leaving scope) the wrapped resource will +automatically be released. + +The main purpose of this class is to make it simple to implement reliable +resource acquisition and release management even if the structure of the code +that refers to that resource is rather complex. + +Furthermore, this class handles cases where the script handling those resources +is spread across different process and/or makes us of signal handlers. + +=cut + +# make sure that we catch any signals in order to properly release scoped +# resources +use sigtrap qw( die normal-signals error-signals ); + +use OpenSLX::Basics; + +=head1 PUBLIC METHODS + +=over + +=item B + +Creates a ScopedResource object for the resource specified by the given +I<$params>. + +As part of creation of the object, the resource will be acquired. + +The I<$params>-hashref requires the following entries: + +=over + +=item C + +Gives a name for the wrapped resource. This is just used in log messages +concerning the acquisition and release of that resource. + +=item C + +Gives the code that is going to be executed in order to acquire the resource. + +=item C + +Gives the code that is going to be executed in order to release the resource. + +=back + +=cut + +sub new +{ + my $class = shift; + my $params = shift; + + checkParams($params, { + name => '!', + acquire => '!', + release => '!', + }); + + my $self = { + name => $params->{name}, + owner => 0, + acquire => $params->{acquire}, + release => $params->{release}, + }; + + bless $self, $class; + + $self->_acquire(); + + return $self; +} + +=item B + +Releases the resource (if it had been acquired by this process) and cleans up. + +=cut + +sub DESTROY +{ + my $self = shift; + + $self->_release(); + + # remove references to functions, in order to release any closures + $self->{acquire} = undef; + $self->{release} = undef; + + return; +} + +sub _acquire +{ + my $self = shift; + + # acquire the resource and set ourselves as owner + if ($self->{acquire}->()) { + vlog(1, "process $$ acquired resource $self->{name}"); + $self->{owner} = $$; + } +} + +sub _release +{ + my $self = shift; + + # only release the resource if invoked by the owning process + vlog(3, "process $$ tries to release resource $self->{name}"); + return if $self->{owner} != $$; + + # ignore ctrl-c while we are trying to release the resource, as otherwise + # the resource would be leaked + local $SIG{INT} = 'IGNORE'; + + # release the resource and unset owner + if ($self->{release}->()) { + vlog(1, "process $$ released resource $self->{name}"); + $self->{owner} = 0; + } +} + +=back + +=cut + +1; diff --git a/src/lib/OpenSLX/Syscall.pm b/src/lib/OpenSLX/Syscall.pm new file mode 100644 index 00000000..2d9182a7 --- /dev/null +++ b/src/lib/OpenSLX/Syscall.pm @@ -0,0 +1,129 @@ +# Copyright (c) 2008 - 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/ +# ----------------------------------------------------------------------------- +# PerlHeaders.pm +# - provides automatic generation of required perl headers (for syscalls) +# ----------------------------------------------------------------------------- +package OpenSLX::Syscall; + +use strict; +use warnings; + +our $VERSION = 1.01; + +=head1 NAME + +OpenSLX::Syscall - provides wrapper functions for syscalls. + +=head1 DESCRIPTION + +This module exports one wrapper function for each syscall that OpenSLX is +using. Each of these functions takes care to load all required Perl-headers +before trying to invoke the respective syscall. + +=cut + +use Config; +use File::Path; + +use OpenSLX::Basics; + +=head1 PUBLIC FUNCTIONS + +=over + +=item B + +Invokes the I syscall in order to enter the 32-bit personality +(C). + +=cut + +sub enter32BitPersonality +{ + _loadPerlHeader('syscall.ph'); + _loadPerlHeader('linux/personality.ph', 'sys/personality.ph'); + + syscall(&SYS_personality, PER_LINUX32()) != -1 + or warn _tr("unable to invoke syscall '%s'! ($!)", 'personality'); + + return; +} + +sub _loadPerlHeader +{ + my @phFiles = @_; + + my @alreadyLoaded = grep { exists $INC{$_} } @phFiles; + return if @alreadyLoaded; + + my $phLibDir = $Config{installsitearch}; + local @INC = @INC; + push @INC, "$phLibDir/asm"; + + # Unability to load an existing Perl header may be caused by missing + # asm-(kernel-)headers, since for instance openSUSE 11 does not provide + # any of these). + # If they are missing, we just have a go at creating all of them: + mkpath($phLibDir) unless -e $phLibDir; + if (!-e "$phLibDir/asm") { + if (-l "/usr/include/asm") { + my $asmFolder = readlink("/usr/include/asm"); + slxsystem("cd /usr/include && h2ph -rQ -d $phLibDir $asmFolder") == 0 + or die _tr('unable to create Perl-header from "asm" folder! (%s)', $!); + slxsystem("mv $phLibDir/$asmFolder $phLibDir/asm") == 0 + or die _tr('unable to cleanup "asm" folder for Perl headers! (%s)', $!); + } + elsif (-d "/usr/include/asm") { + slxsystem("cd /usr/include && h2ph -rQ -d $phLibDir asm") == 0 + or die _tr('unable to create Perl-header from "asm" folder! (%s)', $!); + } + else { + die _tr( + 'the folder "/usr/include/asm" is required - please install kernel headers!\ + \n(maybe linux-libc-dev missing)!' + ); + } + } + if (-e "/usr/include/asm-generic" && !-e "$phLibDir/asm-generic") { + slxsystem("cd /usr/include && h2ph -rQ -d $phLibDir asm-generic") == 0 + or die _tr('unable to create Perl-header from "asm-generic" folder! (%s)', $!); + } + + for my $phFile (@phFiles) { + return 1 if eval { require $phFile }; + + warn(_tr( + 'unable to load Perl-header "%s", trying to create it ...', + $phFile + )); + + # perl-header has not been provided by host-OS, so we create it + # manually from C-header (via h2ph): + (my $hFile = $phFile) =~ s{\.ph$}{.h}; + if (-e "/usr/include/$hFile") { + slxsystem("cd /usr/include && h2ph -aQ -d $phLibDir $hFile") == 0 + or die _tr('unable to create %s! (%s)', $phFile, $!); + } + + return 1 if eval { require $phFile }; + } + + die _tr( + 'unable to load any of these perl headers: %s (%s)', + join(',', @phFiles), $@ + ); +} + +=back + +=cut + +1; diff --git a/src/lib/OpenSLX/Translations/de.pm b/src/lib/OpenSLX/Translations/de.pm new file mode 100644 index 00000000..b0783b81 --- /dev/null +++ b/src/lib/OpenSLX/Translations/de.pm @@ -0,0 +1,359 @@ +# 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/ +# ----------------------------------------------------------------------------- +# de.pm +# - OpenSLX-translations for the German language. +# ----------------------------------------------------------------------------- +package OpenSLX::Translations::de; + +use strict; +use warnings; + +our $VERSION = 0.02; + +my %translations; + +################################################################################ +### Implementation +################################################################################ +sub getAllTranslations +{ + my $class = shift; + return \%translations; +} + +################################################################################ +### Translations +################################################################################ + +%translations = ( + q{NEW:%s doesn't seem to be installed,\nso there is no support for %s available, sorry!\n} + => + qq{}, + + q{NEW:%s has wrong bitwidth (%s instead of %s)} + => + qq{}, + + q{NEW:%s: ignored, as it isn't an executable or a shared library\n} + => + qq{}, + + q{NEW:'%s' already exists!\n} + => + qq{}, + + q{NEW:'%s' not found, maybe wrong root-path?\n} + => + qq{}, + + q{NEW:\trpath='%s'\n} + => + qq{}, + + q{NEW:\ttrying objdump...\n} + => + qq{}, + + q{NEW:\ttrying readelf...\n} + => + qq{}, + + q{NEW:analyzing '%s'...\n} + => + qq{}, + + q{NEW:Can't add column to table <%s> (%s)} + => + qq{}, + + q{NEW:Can't add columns to table <%s> (%s)} + => + qq{}, + + q{NEW:Can't change columns in table <%s> (%s)} + => + qq{}, + + q{NEW:Can't create table <%s> (%s)} + => + qq{}, + + q{NEW:Can't delete from table <%s> (%s)} + => + qq{}, + + q{NEW:Can't drop columns from table <%s> (%s)} + => + qq{}, + + q{NEW:Can't drop table <%s> (%s)} + => + qq{}, + + q{NEW:Can't execute SQL-statement <%s> (%s)} + => + qq{}, + + q{NEW:Can't insert into table <%s> (%s)} + => + qq{}, + + q{NEW:Can't lock ID-file <%s> (%s)} + => + qq{}, + + q{NEW:Can't open ID-file <%s> (%s)} + => + qq{}, + + q{NEW:Can't prepare SQL-statement <%s> (%s)} + => + qq{}, + + q{NEW:Can't rename table <%s> (%s)} + => + qq{}, + + q{NEW:Can't to seek ID-file <%s> (%s)} + => + qq{}, + + q{NEW:Can't truncate ID-file <%s> (%s)} + => + qq{}, + + q{NEW:Can't update ID-file <%s> (%s)} + => + qq{}, + + q{NEW:Can't update table <%s> (%s)} + => + qq{}, + + q{NEW:Cannot connect to database <%s> (%s)} + => + qq{}, + + q{NEW:config-file <%s> has incorrect syntax here:\n\t%s\n} + => + qq{}, + + q{NEW:copying kernel %s to %s/kernel} + => + qq{}, + + q{Could not determine schema version of database} + => + qq{Die Version des Datenbank-Schemas konnte nicht bestimmt werden}, + + q{NEW:Could not load module <%s> (Version <%s> required, but <%s> found)} + => + qq{}, + + q{NEW:creating tar %s} + => + qq{}, + + q{NEW:DB matches current schema version %s} + => + qq{}, + + q{NEW:executing %s} + => + qq{}, + + q{NEW:exporting client %d:%s} + => + qq{}, + + q{NEW:exporting system %d:%s} + => + qq{}, + + q{NEW:generating initialramfs %s/initramfs} + => + qq{}, + + q{NEW:ignoring unknown key <%s>} + => + qq{}, + + q{NEW:List of supported systems:\n\t} + => + qq{}, + + q{NEW:Lock-file <%s> exists, script is already running.\nPlease remove the logfile and try again if you are sure that no one else\nis executing this script.\n} + => + qq{}, + + q{NEW:merging %s (val=%s)} + => + qq{}, + + q{NEW:merging from default client...} + => + qq{}, + + q{NEW:merging from group %d:%s...} + => + qq{}, + + q{NEW:neither objdump nor readelf seems to be installed, giving up!\n} + => + qq{}, + + q{no} + => + qq{nein}, + + q{NEW:Our schema-version is %s, DB is %s, upgrading DB...} + => + qq{}, + + q{NEW:PXE-system %s already exists!} + => + qq{}, + + q{NEW:removing %s} + => + qq{}, + + q{NEW:setting %s to <%s>} + => + qq{}, + + q{NEW:slxldd: unable to find file '%s', skipping it\n} + => + qq{}, + + q{NEW:Sorry, system '%s' is unsupported.\n} + => + qq{}, + + q{NEW:system-error: illegal target-path <%s>!} + => + qq{}, + + q{This will overwrite the current OpenSLX-database with an example dataset.\nAll your data (%s systems and %s clients) will be lost!\nDo you want to continue(%s/%s)? } + => + qq{Die aktuelle OpenSLX-Datenbank wird mit einem Beispiel-Datensatz überschrieben.\nAlle Daten (%s Systeme und %s Clients) werden gelöscht!\nMöchten Sie den Vorgang fortsetzen(%s/%s)? }, + + q{NEW:translations module %s loaded successfully} + => + qq{}, + + q{NEW:Unable to access client-config-path '%s'!} + => + qq{}, + + q{NEW:unable to create db-datadir %s! (%s)\n} + => + qq{}, + + q{NEW:Unable to create lock-file <%s>, exiting!\n} + => + qq{}, + + q{NEW:Unable to create or access temp-path '%s'!} + => + qq{}, + + q{NEW:Unable to create or access tftpboot-path '%s'!} + => + qq{}, + + q{NEW:unable to execute shell-command:\n\t%s \n\t(%s)} + => + qq{}, + + q{NEW:unable to fetch file info for '%s', giving up!\n} + => + qq{}, + + q{NEW:Unable to load DB-module <%s> (%s)\n} + => + qq{}, + + q{NEW:Unable to load DB-module <%s>\nthat database type is not supported (yet?)\n} + => + qq{}, + + q{NEW:unable to load DHCP-Export backend '%s'! (%s)\n} + => + qq{}, + + q{NEW:Unable to load module <%s> (Version <%s> required)} + => + qq{}, + + q{NEW:Unable to load module <%s> (Version <%s> required, but <%s> found)} + => + qq{}, + + q{NEW:Unable to load system-module <%s> (%s)\n} + => + qq{}, + + q{NEW:Unable to load system-module <%s>!\n} + => + qq{}, + + q{NEW:Unable to write local settings file <%s> (%s)} + => + qq{}, + + q{NEW:unknown settings key <%s>!\n} + => + qq{}, + + q{NEW:UnknownDbSchemaColumnDescr} + => + qq{}, + + q{UnknownDbSchemaCommand} + => + qq{Unbekannter DbSchema-Befehl <%s> wird übergangen}, + + q{NEW:UnknownDbSchemaTypeDescr} + => + qq{}, + + q{NEW:upgrade done} + => + qq{}, + + q{NEW:writing dhcp-config for %s clients} + => + qq{}, + + q{NEW:writing PXE-file %s} + => + qq{}, + + q{yes} + => + qq{ja}, + + q{NEW:You need to specify at least one file!\n} + => + qq{}, + + q{NEW:You need to specify exactly one system name!\n} + => + qq{}, + + q{NEW:You need to specify the root-path!\n} + => + qq{}, + +); + +1; diff --git a/src/lib/OpenSLX/Translations/posix.pm b/src/lib/OpenSLX/Translations/posix.pm new file mode 100644 index 00000000..61a94c93 --- /dev/null +++ b/src/lib/OpenSLX/Translations/posix.pm @@ -0,0 +1,359 @@ +# 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/ +# ----------------------------------------------------------------------------- +# posix.pm +# - OpenSLX-translations for the posix locale (English language). +# ----------------------------------------------------------------------------- +package OpenSLX::Translations::posix; + +use strict; +use warnings; + +our $VERSION = 0.02; + +my %translations; + +################################################################################ +### Implementation +################################################################################ +sub getAllTranslations +{ + my $class = shift; + return \%translations; +} + +################################################################################ +### Translations +################################################################################ + +%translations = ( + q{%s doesn't seem to be installed,\nso there is no support for %s available, sorry!\n} + => + qq{%s doesn't seem to be installed,\nso there is no support for %s available, sorry!\n}, + + q{%s has wrong bitwidth (%s instead of %s)} + => + qq{%s has wrong bitwidth (%s instead of %s)}, + + q{%s: ignored, as it isn't an executable or a shared library\n} + => + qq{%s: ignored, as it isn't an executable or a shared library\n}, + + q{'%s' already exists!\n} + => + qq{'%s' already exists!\n}, + + q{'%s' not found, maybe wrong root-path?\n} + => + qq{'%s' not found, maybe wrong root-path?\n}, + + q{\trpath='%s'\n} + => + qq{\trpath='%s'\n}, + + q{\ttrying objdump...\n} + => + qq{\ttrying objdump...\n}, + + q{\ttrying readelf...\n} + => + qq{\ttrying readelf...\n}, + + q{analyzing '%s'...\n} + => + qq{analyzing '%s'...\n}, + + q{Can't add column to table <%s> (%s)} + => + qq{Can't add column to table <%s> (%s)}, + + q{Can't add columns to table <%s> (%s)} + => + qq{Can't add columns to table <%s> (%s)}, + + q{Can't change columns in table <%s> (%s)} + => + qq{Can't change columns in table <%s> (%s)}, + + q{Can't create table <%s> (%s)} + => + qq{Can't create table <%s> (%s)}, + + q{Can't delete from table <%s> (%s)} + => + qq{Can't delete from table <%s> (%s)}, + + q{Can't drop columns from table <%s> (%s)} + => + qq{Can't drop columns from table <%s> (%s)}, + + q{Can't drop table <%s> (%s)} + => + qq{Can't drop table <%s> (%s)}, + + q{Can't execute SQL-statement <%s> (%s)} + => + qq{Can't execute SQL-statement <%s> (%s)}, + + q{Can't insert into table <%s> (%s)} + => + qq{Can't insert into table <%s> (%s)}, + + q{Can't lock ID-file <%s> (%s)} + => + qq{Can't lock ID-file <%s> (%s)}, + + q{Can't open ID-file <%s> (%s)} + => + qq{Can't open ID-file <%s> (%s)}, + + q{Can't prepare SQL-statement <%s> (%s)} + => + qq{Can't prepare SQL-statement <%s> (%s)}, + + q{Can't rename table <%s> (%s)} + => + qq{Can't rename table <%s> (%s)}, + + q{Can't to seek ID-file <%s> (%s)} + => + qq{Can't to seek ID-file <%s> (%s)}, + + q{Can't truncate ID-file <%s> (%s)} + => + qq{Can't truncate ID-file <%s> (%s)}, + + q{Can't update ID-file <%s> (%s)} + => + qq{Can't update ID-file <%s> (%s)}, + + q{Can't update table <%s> (%s)} + => + qq{Can't update table <%s> (%s)}, + + q{Cannot connect to database <%s> (%s)} + => + qq{Cannot connect to database <%s> (%s)}, + + q{config-file <%s> has incorrect syntax here:\n\t%s\n} + => + qq{config-file <%s> has incorrect syntax here:\n\t%s\n}, + + q{copying kernel %s to %s/kernel} + => + qq{copying kernel %s to %s/kernel}, + + q{Could not determine schema version of database} + => + qq{Could not determine schema version of database}, + + q{Could not load module <%s> (Version <%s> required, but <%s> found)} + => + qq{Could not load module <%s> (Version <%s> required, but <%s> found)}, + + q{creating tar %s} + => + qq{creating tar %s}, + + q{DB matches current schema version %s} + => + qq{DB matches current schema version %s}, + + q{executing %s} + => + qq{executing %s}, + + q{exporting client %d:%s} + => + qq{exporting client %d:%s}, + + q{exporting system %d:%s} + => + qq{exporting system %d:%s}, + + q{generating initialramfs %s/initramfs} + => + qq{generating initialramfs %s/initramfs}, + + q{ignoring unknown key <%s>} + => + qq{ignoring unknown key <%s>}, + + q{List of supported systems:\n\t} + => + qq{List of supported systems:\n\t}, + + q{Lock-file <%s> exists, script is already running.\nPlease remove the logfile and try again if you are sure that no one else\nis executing this script.\n} + => + qq{Lock-file <%s> exists, script is already running.\nPlease remove the logfile and try again if you are sure that no one else\nis executing this script.\n}, + + q{merging %s (val=%s)} + => + qq{merging %s (val=%s)}, + + q{merging from default client...} + => + qq{merging from default client...}, + + q{merging from group %d:%s...} + => + qq{merging from group %d:%s...}, + + q{neither objdump nor readelf seems to be installed, giving up!\n} + => + qq{neither objdump nor readelf seems to be installed, giving up!\n}, + + q{no} + => + qq{no}, + + q{Our schema-version is %s, DB is %s, upgrading DB...} + => + qq{Our schema-version is %s, DB is %s, upgrading DB...}, + + q{PXE-system %s already exists!} + => + qq{PXE-system %s already exists!}, + + q{removing %s} + => + qq{removing %s}, + + q{setting %s to <%s>} + => + qq{setting %s to <%s>}, + + q{slxldd: unable to find file '%s', skipping it\n} + => + qq{slxldd: unable to find file '%s', skipping it\n}, + + q{Sorry, system '%s' is unsupported.\n} + => + qq{Sorry, system '%s' is unsupported.\n}, + + q{system-error: illegal target-path <%s>!} + => + qq{system-error: illegal target-path <%s>!}, + + q{This will overwrite the current OpenSLX-database with an example dataset.\nAll your data (%s systems and %s clients) will be lost!\nDo you want to continue(%s/%s)? } + => + qq{This will overwrite the current OpenSLX-database with an example dataset.\nAll your data (%s systems and %s clients) will be lost!\nDo you want to continue(%s/%s)? }, + + q{translations module %s loaded successfully} + => + qq{translations module %s loaded successfully}, + + q{Unable to access client-config-path '%s'!} + => + qq{Unable to access client-config-path '%s'!}, + + q{unable to create db-datadir %s! (%s)\n} + => + qq{unable to create db-datadir %s! (%s)\n}, + + q{Unable to create lock-file <%s>, exiting!\n} + => + qq{Unable to create lock-file <%s>, exiting!\n}, + + q{Unable to create or access temp-path '%s'!} + => + qq{Unable to create or access temp-path '%s'!}, + + q{Unable to create or access tftpboot-path '%s'!} + => + qq{Unable to create or access tftpboot-path '%s'!}, + + q{unable to execute shell-command:\n\t%s \n\t(%s)} + => + qq{unable to execute shell-command:\n\t%s \n\t(%s)}, + + q{unable to fetch file info for '%s', giving up!\n} + => + qq{unable to fetch file info for '%s', giving up!\n}, + + q{Unable to load DB-module <%s> (%s)\n} + => + qq{Unable to load DB-module <%s> (%s)\n}, + + q{Unable to load DB-module <%s>\nthat database type is not supported (yet?)\n} + => + qq{Unable to load DB-module <%s>\nthat database type is not supported (yet?)\n}, + + q{unable to load DHCP-Export backend '%s'! (%s)\n} + => + qq{unable to load DHCP-Export backend '%s'! (%s)\n}, + + q{Unable to load module <%s> (Version <%s> required)} + => + qq{Unable to load module <%s> (Version <%s> required)}, + + q{Unable to load module <%s> (Version <%s> required, but <%s> found)} + => + qq{Unable to load module <%s> (Version <%s> required, but <%s> found)}, + + q{Unable to load system-module <%s> (%s)\n} + => + qq{Unable to load system-module <%s> (%s)\n}, + + q{Unable to load system-module <%s>!\n} + => + qq{Unable to load system-module <%s>!\n}, + + q{Unable to write local settings file <%s> (%s)} + => + qq{Unable to write local settings file <%s> (%s)}, + + q{unknown settings key <%s>!\n} + => + qq{unknown settings key <%s>!\n}, + + q{UnknownDbSchemaColumnDescr} + => + qq{UnknownDbSchemaColumnDescr}, + + q{UnknownDbSchemaCommand} + => + qq{UnknownDbSchemaCommand}, + + q{UnknownDbSchemaTypeDescr} + => + qq{UnknownDbSchemaTypeDescr}, + + q{upgrade done} + => + qq{upgrade done}, + + q{writing dhcp-config for %s clients} + => + qq{writing dhcp-config for %s clients}, + + q{writing PXE-file %s} + => + qq{writing PXE-file %s}, + + q{yes} + => + qq{yes}, + + q{You need to specify at least one file!\n} + => + qq{You need to specify at least one file!\n}, + + q{You need to specify exactly one system name!\n} + => + qq{You need to specify exactly one system name!\n}, + + q{You need to specify the root-path!\n} + => + qq{You need to specify the root-path!\n}, + +); + +1; diff --git a/src/lib/OpenSLX/Utils.pm b/src/lib/OpenSLX/Utils.pm new file mode 100644 index 00000000..6e722c00 --- /dev/null +++ b/src/lib/OpenSLX/Utils.pm @@ -0,0 +1,701 @@ +# 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/ +# ----------------------------------------------------------------------------- +# Utils.pm +# - provides utility functions for OpenSLX +# ----------------------------------------------------------------------------- +package OpenSLX::Utils; + +use strict; +use warnings; + +use vars qw(@ISA @EXPORT $VERSION); + +use Exporter; +$VERSION = 1.01; +@ISA = qw(Exporter); + +@EXPORT = qw( + copyFile fakeFile linkFile + copyBinaryWithRequiredLibs + slurpFile spitFile appendFile + followLink + unshiftHereDoc + string2Array trim + chrootInto + mergeHash + getFQDN + readPassword + hostIs64Bit + getAvailableBusyboxApplets + grabLock + pathOf + isInPath +); + +=head1 NAME + +OpenSLX::Utils - provides utility functions for OpenSLX. + +=head1 DESCRIPTION + +This module exports utility functions, which are expected to be used all across +OpenSLX. + +=cut + +use Fcntl qw(:DEFAULT :flock); +use File::Basename; +use File::Path; +use Socket; +use Sys::Hostname; +use Term::ReadLine; + +use OpenSLX::Basics; +use OpenSLX::ScopedResource; + +=head1 PUBLIC FUNCTIONS + +=over + +=item B + +Copies the file specified by I<$fileName> to the folder I<$targetDir>, +preserving the permissions and optionally renaming it to I<$targetFileName> +during the process. + +If I<$targetDir> does not exist yet, it will be created. + +=cut + +sub copyFile +{ + my $fileName = shift || croak 'need to pass in a fileName!'; + my $targetDir = shift || croak 'need to pass in target dir!'; + my $targetFileName = shift || ''; + + mkpath($targetDir) unless -d $targetDir; + my $target = "$targetDir/$targetFileName"; + vlog(2, _tr("copying '%s' to '%s'", $fileName, $target)); + if (system("cp -p $fileName $target")) { + croak( + _tr( + "unable to copy file '%s' to dir '%s' (%s)", + $fileName, $target, $! + ) + ); + } + return; +} + +=item B + +Creates the (empty) file I<$fullPath> unless it already exists. + +If the parent directory of I<$fullPath> does not exist yet, it will be created. + +=cut + +sub fakeFile +{ + my $fullPath = shift || croak 'need to pass in full path!'; + + return if -e $fullPath; + + my $targetDir = dirname($fullPath); + mkpath($targetDir) unless -d $targetDir; + + if (system("touch", $fullPath)) { + croak(_tr("unable to create file '%s' (%s)", $fullPath, $!)); + } + return; +} + +=item B + +Creates the link I<$linkName> that points to I<$linkTarget>. + +If the directory where the new link shall live does not exist yet, it will be +created. + +=cut + +sub linkFile +{ + my $linkTarget = shift || croak 'need to pass in link target!'; + my $linkName = shift || croak 'need to pass in link name!'; + + my $targetDir = dirname($linkName); + mkpath($targetDir) unless -d $targetDir; + if (system("ln -sfn $linkTarget $linkName")) { + croak( + _tr( + "unable to create link '%s' to '%s' (%s)", + $linkName, $linkTarget, $! + ) + ); + } + return; +} + +=item B + +Reads the file specified by <$fileName> and returns the contents. + +The optional hash-ref I<$flags> supports the following entries: + +=over + +=item failIfMissing + +Specifies what shall happen if the file does not exist: die (failIfMissing == 1) +or return an empty string (failIfMissing == 0). Defaults to 1. + +=item io-layer + +Specifies the Perl-IO-layer that shall be applied to the file (defaults to +'utf8'). + +=back + +=cut + +sub slurpFile +{ + my $fileName = shift || confess 'need to pass in fileName!'; + my $flags = shift || {}; + + checkParams($flags, { + 'failIfMissing' => '?', + 'io-layer' => '?', + }); + my $failIfMissing + = exists $flags->{failIfMissing} ? $flags->{failIfMissing} : 1; + my $ioLayer = $flags->{'io-layer'} || 'utf8'; + + my $fh; + if (!open($fh, "<:$ioLayer", $fileName)) { + return '' unless $failIfMissing; + croak _tr("could not open file '%s' for reading! (%s)", $fileName, $!); + } + if (wantarray()) { + my @content = <$fh>; + close($fh) + or croak _tr("unable to close file '%s' (%s)\n", $fileName, $!); + return @content; + } + else { + local $/; + my $content = <$fh>; + close($fh) + or croak _tr("unable to close file '%s' (%s)\n", $fileName, $!); + return $content; + } +} + +=item B + +Writes the given I<$content> to the file specified by <$fileName>, creating +the file (and any missing directories) if it does not exist yet. + +The optional hash-ref I<$flags> supports the following entries: + +=over + +=item io-layer + +Specifies the Perl-IO-layer that shall be applied to the file (defaults to +'utf8'). + +=item mode + +Specifies the file mode that shall be applied to the file (via chmod). + +=back + +=cut + +sub spitFile +{ + my $fileName = shift || croak 'need to pass in a fileName!'; + my $content = shift || ''; + my $flags = shift || {}; + + checkParams($flags, { + 'io-layer' => '?', + 'mode' => '?', + }); + my $ioLayer = $flags->{'io-layer'} || 'utf8'; + + my $targetDir = dirname($fileName); + mkpath($targetDir) unless -d $targetDir; + + my $fh; + open($fh, ">:$ioLayer", $fileName) + or croak _tr("unable to create file '%s' (%s)\n", $fileName, $!); + print $fh $content + or croak _tr("unable to print to file '%s' (%s)\n", $fileName, $!); + close($fh) + or croak _tr("unable to close file '%s' (%s)\n", $fileName, $!); + if (defined $flags->{mode}) { + chmod $flags->{mode}, $fileName; + } + return; +} + +=item B + +Appends the given I<$content> to the file specified by <$fileName>, creating +the file (and any missing directories) if it does not exist yet. + +The optional hash-ref I<$flags> supports the following entries: + +=over + +=item io-layer + +Specifies the Perl-IO-layer that shall be applied to the file (defaults to +'utf8'). + +=back + +=cut + +sub appendFile +{ + my $fileName = shift || croak 'need to pass in a fileName!'; + my $content = shift; + my $flags = shift || {}; + + checkParams($flags, { + 'io-layer' => '?', + }); + my $ioLayer = $flags->{'io-layer'} || 'utf8'; + + my $targetDir = dirname($fileName); + mkpath($targetDir) unless -d $targetDir; + + my $fh; + open($fh, ">>:$ioLayer", $fileName) + or croak _tr("unable to create file '%s' (%s)\n", $fileName, $!); + print $fh $content + or croak _tr("unable to print to file '%s' (%s)\n", $fileName, $!); + close($fh) + or croak _tr("unable to close file '%s' (%s)\n", $fileName, $!); + return; +} + +=item B + +Deeply traverses the given I<$path> until it no longer contains a link and +returns the resulting file or directory. + +If you pass in a I<$prefixedPath>, each link will be resolved relatively to +that path (useful for example with respect to chroot-environments). + +=cut + +sub followLink +{ + my $path = shift || croak 'need to pass in a path!'; + my $prefixedPath = shift || ''; + + my $target; + while (-l "$path") { + $target = readlink "$path"; + if (substr($target, 0, 1) eq '/') { + $path = "$prefixedPath$target"; + } + else { + $path = $prefixedPath . dirname($path) . '/' . $target; + } + } + return $path; +} + +=item B + +Copies a binary to a specified folder, taking along all the libraries that +are required by this binary. + +The hash-ref I<$params> supports the following entries: + +=over + +=item binary + +The full path to the binary that shall be copied. + +=item targetFolder + +The full path to the folder where the binary shall be copied to. + +=item libTargetFolder + +Defines a path relatively to which all required libs will be copied to. + +An example: during execution of + + copyBinaryWithRequiredLibs({ + binary => '/bin/ls', + targetFolder => '/tmp/slx-initramfs/bin', + libTargetFolder => '/tmp/slx-initramfs', + }); + +the library C will be copied to +C. + +=item targetName [optional] + +If you'd like to rename the binary while copying, you can specify the new name +in this entry. + +=back + +=cut + +sub copyBinaryWithRequiredLibs { + my $params = shift; + + checkParams($params, { + 'binary' => '!', # file to copy + 'targetFolder' => '!', # where file shall be copied to + 'libTargetFolder' => '!', # base target folder for libs + 'targetName' => '?', # name of binary in target folder + }); + copyFile($params->{binary}, $params->{targetFolder}, $params->{targetName}); + + # determine all required libraries and copy those, too: + vlog(1, _tr("calling slxldd for $params->{binary}")); + my $slxlddCmd = "slxldd $params->{binary}"; + vlog(2, "executing: $slxlddCmd"); + my $requiredLibsStr = qx{$slxlddCmd}; + if ($?) { + die _tr( + "slxldd couldn't determine the libs required by '%s'! (%s)", + $params->{binary}, $? + ); + } + chomp $requiredLibsStr; + vlog(2, "slxldd results:\n$requiredLibsStr"); + + foreach my $lib (split "\n", $requiredLibsStr) { + my $libDir = dirname($lib); + my $targetLib = "$params->{libTargetFolder}$libDir"; + next if -e "$targetLib/$lib"; + vlog(3, "copying lib '$lib'"); + copyFile($lib, $targetLib); + } + return $requiredLibsStr; +} + +=item B + +Returns the here-doc (or string) given in I<$content> such that the leading +whitespace found on the first line will be removed from all lines. + +As an example: if you pass in the string + + #!/bin/sh + if [ -n "$be_nice" ]; then + echo "bummer!" >/etc/passwd + fi + +you will get this: + +#!/bin/sh +if [ -n "$be_nice" ]; then + echo "bummer!" >/etc/passwd +fi + +=cut + +sub unshiftHereDoc +{ + my $content = shift; + return $content unless $content =~ m{^(\s+)}; + my $shiftStr = $1; + $content =~ s[^$shiftStr][]gms; + return $content; +} + +=item B + +Returns the given string split into an array, using newlines as separator. + +In the resulting array, empty entries will have been removed and each entry +will be trimmed of leading or trailing whitespace and comments (lines starting +with a #). + +=cut + +sub string2Array +{ + my $string = shift || ''; + + my @lines = split m[\n], $string; + for my $line (@lines) { + # remove leading and trailing whitespace: + $line =~ s{^\s*(.*?)\s*$}{$1}; + } + + # drop empty lines and comments: + return grep { length($_) > 0 && $_ !~ m[^\s*#]; } @lines; +} + +=item B + +Does a chroot() into the given directory (which is supposed to contain at +least the fragments of an operating system). + +=cut + +sub chrootInto +{ + my $osDir = shift; + + vlog(2, "chrooting into $osDir..."); + chdir $osDir + or die _tr("unable to chdir into '%s' (%s)\n", $osDir, $!); + + # ...do chroot + chroot "." + or die _tr("unable to chroot into '%s' (%s)\n", $osDir, $!); + return; +} + +=item B + +Deeply copies values from I<$sourceHash> into I<$targetHash>. + +If you pass in 1 for I<$fillOnly>, only hash entries that do not exist in +I<$targetHash> will be copied (C-mode), otherwise all values from +I<$sourceHash> will be copied over (C-mode). + +Returns the resulting I<$targetHash> for convenience. + +=cut + +sub mergeHash +{ + my $targetHash = shift; + my $sourceHash = shift; + my $fillOnly = shift || 0; + + foreach my $key (keys %{$sourceHash}) { + my $sourceVal = $sourceHash->{$key}; + if (ref($sourceVal) eq 'HASH') { + if (!exists $targetHash->{$key}) { + $targetHash->{$key} = {}; + } + mergeHash($targetHash->{$key}, $sourceVal); + } + elsif (ref($sourceVal) eq 'ARRAY') { + if (!exists $targetHash->{$key}) { + $targetHash->{$key} = []; + } + foreach my $val (@{$sourceHash->{$key}}) { + my $targetVal = {}; + push @{$targetHash->{$key}}, $targetVal; + mergeHash($targetVal, $sourceVal); + } + } + else { + next if $fillOnly && exists $targetHash->{$key}; + $targetHash->{$key} = $sourceVal; + } + } + return $targetHash; +} + +=item B + +Determines the fully-qualified-domain-name (FQDN) of the computer executing +this function and returns it. + +=cut + +sub getFQDN +{ + my $hostName = hostname(); + + my $hostAddr = gethostbyname($hostName) + or die(_tr("unable to get address of host '%s'", $hostName)); + my $FQDN = gethostbyaddr($hostAddr, AF_INET) + or die(_tr("unable to get dns-name of address '%s'", $hostAddr)); + return $FQDN; +} + +=item B + +Outputs the given I<$prompt> and then reads a password from the terminal +(trying to make sure that the characters are not echoed in a readable form). + +=cut + +sub readPassword +{ + my $prompt = shift; + + my $term = Term::ReadLine->new('slx'); + my $attribs = $term->Attribs; + $attribs->{redisplay_function} = $attribs->{shadow_redisplay}; + + return $term->readline($prompt); +} + +=item B + +Returns 1 if the host (the computer executing this function) is running a +64-bit OS, 0 if not (i.e. 32-bit). + +=cut + +sub hostIs64Bit +{ + my $arch = qx{uname -m}; + return $arch =~ m[64]; +} + +=item B + +Returns the list of the applets that is provided by the given busybox binary. + +=cut + +sub getAvailableBusyboxApplets +{ + my $busyboxBinary = shift; + + my $busyboxHelp = qx{$busyboxBinary --help}; + if ($busyboxHelp !~ m{defined functions:(.+)\z}ims) { + die "unable to parse busybox --help output:\n$busyboxHelp"; + } + my $rawAppletList = $1; + my @busyboxApplets + = map { + $_ =~ s{\s+}{}igms; + $_; + } + split m{,}, $rawAppletList; + + return @busyboxApplets; +} + +=item grabLock() + +=cut + +sub grabLock +{ + my $lockName = shift || die 'you need to pass a lock-name to grabLock()!'; + + my $lockPath = "$openslxConfig{'private-path'}/locks"; + mkpath($lockPath) unless -e $lockPath; + + # drop any trailing slashes from lock name: + $lockName =~ s{/+$}{}; + my $lockFile = "$lockPath/$lockName"; + + my $lockFH; + + my $lock = OpenSLX::ScopedResource->new({ + name => "lock::$lockName", + acquire => sub { + # use a lock-file to implement the actual locking: + if (-e $lockFile) { + my $ctime = (stat($lockFile))[10]; + my $now = time(); + if ($now - $ctime > 15 * 60) { + # existing lock file is older than 15 minutes, we consider + # that to be a leftover (which shouldn't happen of course) + # and wipe it: + unlink $lockFile; + } + } + + local $| = 1; + my $waiting; + while(!(sysopen($lockFH, $lockFile, O_RDWR | O_CREAT | O_EXCL) + && syswrite($lockFH, getpgrp() . "\n"))) { + if ($! == 13) { + die _tr( + qq[Unable to create lock "%s", giving up!], $lockFile + ); + } else { + # check if the lock is owned by our own process group + # and only block if it isn't (this allows recursive locking) + my $pgrpOfLock + = slurpFile($lockFile, { failIfMissing => 0}); + last if $pgrpOfLock && $pgrpOfLock == getpgrp(); + + # wait for lock to become available + if (!$waiting) { + print _tr('waiting for "%s"-lock ', $lockName); + $waiting = 1; + } + else { + print '.'; + } + sleep(1); + } + } + print "ok\n" if $waiting; + 1 + }, + release => sub { + close($lockFH); + unlink $lockFile; + 1 + }, + }); + + return $lock; +} + +=item B + +Returns the path of a binary it is installed in. + +=cut + +sub pathOf +{ + my $binary = shift; + return qx{which $binary 2>/dev/null}; +} + +=item B + +Returns whether a binary is found. + +=cut + +sub isInPath +{ + my $binary = shift; + my $path = pathOf($binary); + + return $path ? 1 : 0; +} + + +sub trim +{ + my $string = shift; + + $string =~ s/^\s+//; + $string =~ s/\s+$//; + + return $string; +} + + +1; -- cgit v1.2.3-55-g7522