path: root/src/lib/OpenSLX/Utils.pm

# 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;