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/Utils.pm | 701 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 701 insertions(+) create mode 100644 src/lib/OpenSLX/Utils.pm (limited to 'src/lib/OpenSLX/Utils.pm') 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