From ed7668aa585fe38de621f919e1ee84c62cb56104 Mon Sep 17 00:00:00 2001 From: Oliver Tappe Date: Sun, 6 Apr 2008 17:47:41 +0000 Subject: * added PODs to all Perl-modules in lib, documenting those functions that are meant to be used by other OpenSLX components (i.e. scripts and plugins) * applied minor cleanups and convenience extensions to a couple of functions git-svn-id: http://svn.openslx.org/svn/openslx/openslx/trunk@1722 95ad53e4-c205-0410-b2fa-d234c58c8868 --- lib/OpenSLX/Basics.pm | 474 +++++++++++++++++++++++++++++------------- lib/OpenSLX/ConfigFolder.pm | 64 +++++- lib/OpenSLX/ScopedResource.pm | 115 ++++++++-- lib/OpenSLX/Syscall.pm | 45 +++- lib/OpenSLX/Utils.pm | 241 ++++++++++++++++++++- 5 files changed, 756 insertions(+), 183 deletions(-) diff --git a/lib/OpenSLX/Basics.pm b/lib/OpenSLX/Basics.pm index e46f57f0..fce40cfc 100644 --- a/lib/OpenSLX/Basics.pm +++ b/lib/OpenSLX/Basics.pm @@ -8,9 +8,6 @@ # # General information about OpenSLX can be found at http://openslx.org/ # ----------------------------------------------------------------------------- -# Basics.pm -# - provides basic functionality of the OpenSLX config-db. -# ----------------------------------------------------------------------------- package OpenSLX::Basics; use strict; @@ -24,7 +21,7 @@ $VERSION = 1.01; @EXPORT = qw( &openslxInit %openslxConfig %cmdlineConfig - &_tr &trInit + &_tr &warn &die &croak &carp &confess &cluck &callInSubprocess &executeInSubprocess &slxsystem &vlog @@ -32,15 +29,23 @@ $VERSION = 1.01; &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'; -################################################################################ -### Module implementation -################################################################################ require Carp; # do not import anything as we are going to overload carp # and croak! use Carp::Heavy; # use it here to have it loaded immediately, not at @@ -57,9 +62,23 @@ use POSIX qw(locale_h); my $translations; -# this hash will hold the active openslx configuration, -# the initial content is based on environment variables or default values. -# Each value may be overridden from config files and/or cmdline arguments. +=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}, @@ -95,6 +114,16 @@ my $translations; ); 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 = ( @@ -142,20 +171,24 @@ my $openslxLog = *STDERR; $Carp::CarpLevel = 1; -# ------------------------------------------------------------------------------ -sub vlog -{ - my $minLevel = shift; - return if $minLevel > $openslxConfig{'verbose-level'}; - my $str = join("", '-' x $minLevel, @_); - if (substr($str, -1, 1) ne "\n") { - $str .= "\n"; - } - print $openslxLog $str; - return; -} +=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: @@ -221,69 +254,40 @@ sub openslxInit } # setup translation "engine": - trInit(); + _trInit(); return 1; } -# ------------------------------------------------------------------------------ -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'})"); +=item B - my $locale = $openslxConfig{'locale'}; - if (lc($locale) eq 'c') { - # treat locale 'c' as equivalent for 'posix': - $locale = 'posix'; - } +Logs the given I<$message> if the current log level is equal or greater than +the given I<$level>. - 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); +=cut - # 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' ($!)." - ); - } +sub vlog +{ + my $minLevel = shift; + return if $minLevel > $openslxConfig{'verbose-level'}; + my $str = join("", '-' x $minLevel, @_); + if (substr($str, -1, 1) ne "\n") { + $str .= "\n"; } + 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; @@ -302,7 +306,19 @@ sub _tr 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; @@ -326,7 +342,16 @@ sub callInSubprocess 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 = @_; @@ -343,7 +368,19 @@ sub executeInSubprocess 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 ' ', @_)); @@ -354,103 +391,63 @@ sub slxsystem # and the like): my $signalNo = $res & 127; if ($signalNo > 0 && $signalNo != 13) { - die _tr("child-process reveived signal '%s', parent stops!", - $signalNo); + 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; } -# ------------------------------------------------------------------------------ -sub _doThrowOrWarn -{ - my $type = shift; - my $msg = shift; - - # use '°°°' for warnings and '***' for errors - if ($type eq 'carp' || $type eq 'warn' || $type eq 'cluck') { - $msg =~ s[^°°° ][]igms; - $msg =~ s[^][°°° ]igms; - } - else { - $msg =~ s[^\*\*\* ][]igms; - $msg =~ s[^][*** ]igms; - } +=item B - 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; -} - -=item checkParams() - -Utility function that can be used by any method that accepts param-hashes -to check if the given parameters actually match the expectations. +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 @@ -464,9 +461,6 @@ are supported: The function will confess for any unknown, missing, or non-matching param. -If accepted as useful, this function could be moved to a utility module of -the framework in order to be available to all other OTRS-modules. - =cut sub checkParams @@ -554,7 +548,41 @@ sub checkParams 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; @@ -598,6 +626,61 @@ sub instantiateClass 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; @@ -617,16 +700,14 @@ sub loadDistroModule # try to load the distro module starting with the given name and then # working the way upwards (from most specific to generic). - # When given 'suse-10.3_x86_64', this would try the following modules: - # Suse_10_3_x86_64 - # Suse_10_3_x86 (pretty senseless, but what the heck ...) - # Suse_10_3 - # Suse_10 - # Suse - # Base (or whatever has been given as fallback name) $distroName =~ tr{.-}{__}; my @distroModules; - while($distroName =~ m{^(.+)_[^_]*$}) { + 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; } @@ -661,4 +742,107 @@ sub loadDistroModule 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 + if ($type eq 'carp' || $type eq 'warn' || $type eq 'cluck') { + $msg =~ s[^°°° ][]igms; + $msg =~ s[^][°°° ]igms; + } + else { + $msg =~ s[^\*\*\* ][]igms; + $msg =~ s[^][*** ]igms; + } + + 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/lib/OpenSLX/ConfigFolder.pm b/lib/OpenSLX/ConfigFolder.pm index e8c3ee8f..fd52821e 100644 --- a/lib/OpenSLX/ConfigFolder.pm +++ b/lib/OpenSLX/ConfigFolder.pm @@ -8,9 +8,6 @@ # # General information about OpenSLX can be found at http://openslx.org/ # ----------------------------------------------------------------------------- -# ConfigFolder.pm -# - provides utility functions for generation of configuration folders -# ----------------------------------------------------------------------------- package OpenSLX::ConfigFolder; use strict; @@ -27,12 +24,45 @@ $VERSION = 1.01; &createConfigFolderForSystem ); -################################################################################ -### Module implementation -################################################################################ +=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; @@ -81,6 +111,24 @@ sub createConfigFolderForDefaultSystem 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!"; @@ -99,4 +147,8 @@ sub createConfigFolderForSystem return $result; } +=back + +=cut + 1; diff --git a/lib/OpenSLX/ScopedResource.pm b/lib/OpenSLX/ScopedResource.pm index c905b50a..f278f871 100644 --- a/lib/OpenSLX/ScopedResource.pm +++ b/lib/OpenSLX/ScopedResource.pm @@ -8,9 +8,6 @@ # # General information about OpenSLX can be found at http://openslx.org/ # ----------------------------------------------------------------------------- -# ScopedResource.pm -# - a helper class that releases resources if the object leaves scope -# ----------------------------------------------------------------------------- package OpenSLX::ScopedResource; use strict; @@ -18,12 +15,84 @@ 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 released 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; @@ -44,12 +113,31 @@ sub new bless $self, $class; - $self->acquire(); + $self->_acquire(); return $self; } -sub acquire +=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; @@ -60,7 +148,7 @@ sub acquire } } -sub release +sub _release { my $self = shift; @@ -75,17 +163,8 @@ sub release } } -sub DESTROY -{ - my $self = shift; - - $self->release(); - - # remove references to functions, in order to release any closures - $self->{acquire} = undef; - $self->{release} = undef; - - return; -} +=back + +=cut 1; diff --git a/lib/OpenSLX/Syscall.pm b/lib/OpenSLX/Syscall.pm index 5d82a361..a46d9ac6 100644 --- a/lib/OpenSLX/Syscall.pm +++ b/lib/OpenSLX/Syscall.pm @@ -18,8 +18,42 @@ 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 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 = @_; @@ -42,15 +76,8 @@ sub _loadPerlHeader ); } -sub enter32BitPersonality -{ - _loadPerlHeader('syscall.ph'); - _loadPerlHeader('linux/personality.ph', 'sys/personality.ph'); +=back - syscall(&SYS_personality, PER_LINUX32()) != -1 - or warn _tr("unable to invoke syscall '%s'! ($!)", 'personality'); - - return; -} +=cut 1; diff --git a/lib/OpenSLX/Utils.pm b/lib/OpenSLX/Utils.pm index 40cc9715..346e9d4d 100644 --- a/lib/OpenSLX/Utils.pm +++ b/lib/OpenSLX/Utils.pm @@ -36,9 +36,17 @@ $VERSION = 1.01; hostIs64Bit ); -################################################################################ -### Module implementation -################################################################################ +=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 File::Basename; use File::Path; use Socket; @@ -47,7 +55,19 @@ use Term::ReadLine; use OpenSLX::Basics; -# TODO: write POD for all these functions! +=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 { @@ -69,18 +89,38 @@ sub copyFile 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!'; @@ -99,6 +139,28 @@ sub linkFile 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!'; @@ -132,6 +194,28 @@ sub slurpFile } } +=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!'; @@ -144,6 +228,9 @@ sub spitFile }); 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, $!); @@ -157,6 +244,24 @@ sub spitFile 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!'; @@ -168,6 +273,9 @@ sub appendFile }); 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, $!); @@ -178,6 +286,16 @@ sub appendFile 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!'; @@ -196,11 +314,52 @@ sub followLink 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 + 'binary' => '!', # file to copy 'targetFolder' => '!', # where file shall be copied to 'libTargetFolder' => '!', # base target folder for libs 'targetName' => '?', # name of binary in target folder @@ -231,6 +390,27 @@ sub copyBinaryWithRequiredLibs { 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; @@ -240,6 +420,16 @@ sub unshiftHereDoc 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 || ''; @@ -254,6 +444,13 @@ sub string2Array 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; @@ -268,6 +465,18 @@ sub chrootInto 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; @@ -297,8 +506,16 @@ sub mergeHash $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(); @@ -310,6 +527,13 @@ sub getFQDN 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; @@ -321,6 +545,13 @@ sub readPassword 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}; -- cgit v1.2.3-55-g7522