summaryrefslogtreecommitdiffstats
path: root/src/lib/OpenSLX/Utils.pm
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/OpenSLX/Utils.pm')
-rw-r--r--src/lib/OpenSLX/Utils.pm701
1 files changed, 701 insertions, 0 deletions
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<copyFile($fileName, $targetDir, $targetFileName)>
+
+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<fakeFile($fullPath)>
+
+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<linkFile($linkTarget, $linkName)>
+
+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<slurpFile($fileName, $flags)>
+
+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<spitFile($fileName, $content, $flags)>
+
+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<appendFile($fileName, $content, $flags)>
+
+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<followLink($path, $prefixedPath)>
+
+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<copyBinaryWithRequiredLibs($params)>
+
+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<lib/libc-2.6.1.so> will be copied to
+C</tmp/slx-initramfs/lib/libc-2.6.1.so>.
+
+=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<unshiftHereDoc($content)>
+
+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<string2Array($string)>
+
+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<chrootInto($osDir)>
+
+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<mergeHash($targetHash, $sourceHash, $fillOnly)>
+
+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<Merge>-mode), otherwise all values from
+I<$sourceHash> will be copied over (C<Push>-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<getFQDN()>
+
+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<readPassword($prompt)>
+
+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<hostIs64Bit()>
+
+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<getAvailableBusyboxApplets()>
+
+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<pathOf()>
+
+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<isInpath()>
+
+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;
generated by cgit v1.2.3-55-g7522 (git 2.39.0) at 2024-04-28 18:43:33 +0200