path: root/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
  chrootInto
  mergeHash
  getFQDN
  readPassword
  hostIs64Bit
);

################################################################################
### Module implementation
################################################################################
use File::Basename;
use File::Path;
use Socket;
use Sys::Hostname;
use Term::ReadLine;

use OpenSLX::Basics;

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

sub fakeFile
{
    my $fullPath = shift || croak 'need to pass in full path!';

    my $targetDir = dirname($fullPath);
    mkpath($targetDir) unless -d $targetDir;
    if (system("touch", $fullPath)) {
        croak(_tr("unable to create file '%s' (%s)", $fullPath, $!));
    }
    return;
}

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

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

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 $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;
}

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 $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;
}

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

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

sub unshiftHereDoc
{
    my $content = shift;
    return $content unless $content =~ m{^(\s+)};
    my $shiftStr = $1;
    $content =~ s[^$shiftStr][]gms;
    return $content;
}

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

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

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

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

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);
}

sub hostIs64Bit
{
    my $arch = qx{uname -m};
    return $arch =~ m[64];
}

1;