File Coverage

blib/lib/FusionInventory/Agent/Tools.pm

Criterion	Covered	Total	%
statement	211	245	86.1
branch	104	152	68.4
condition	7	11	63.6
subroutine	39	44	88.6
pod	30	30	100.0
total	391	482	81.1

package FusionInventory::Agent::Tools;

use strict;
use warnings;
use base 'Exporter';

use Encode qw(encode);
use English qw(-no_match_vars);
use File::Basename;
use File::Spec;
use File::stat;
use File::Which;
use Memoize;
use UNIVERSAL::require;

our @EXPORT = qw(
    getDirectoryHandle
    getFileHandle
    getFormatedLocalTime
    getFormatedGMTTime
    getFormatedDate
    getCanonicalManufacturer
    getCanonicalSpeed
    getCanonicalInterfaceSpeed
    getCanonicalSize
    getSanitizedString
    trimWhitespace
    getFirstLine
    getFirstMatch
    getLastLine
    getAllLines
    getLinesCount
    compareVersion
    canRun
    hex2char
    hex2dec
    dec2hex
    any
    all
    none
    uniq
    file2module
    module2file
    runFunction
    delay
    slurp
    isParamArrayAndFilled
);

my $nowhere = $OSNAME eq 'MSWin32' ? 'nul' : '/dev/null';

# this trigger some errors on Perl 5.12/Win32:
# Anonymous function called in forbidden scalar context
if ($OSNAME ne 'MSWin32') {
    memoize('canRun');
}

sub getFormatedLocalTime {
    my ($time) = @_;

    return unless $time;

    my ($year, $month , $day, $hour, $min, $sec) =
        (localtime ($time))[5, 4, 3, 2, 1, 0];

    return getFormatedDate(
        ($year + 1900), ($month + 1), $day, $hour, $min, $sec
    );
}

sub getFormatedGMTTime {
    my ($time) = @_;

    my ($year, $month , $day, $hour, $min, $sec) =
        (gmtime ($time))[5, 4, 3, 2, 1, 0];

    return getFormatedDate(
        ($year - 70), $month, ($day - 1), $hour, $min, $sec
    );
}

sub getFormatedDate {
    my ($year, $month, $day, $hour, $min, $sec) = @_;

    return sprintf
        "%02d-%02d-%02d %02d:%02d:%02d",
        $year, $month, $day, $hour, $min, $sec;
}

sub getCanonicalManufacturer {
    my ($manufacturer) = @_;

    return unless $manufacturer;

    my %manufacturers = (
        GenuineIntel => 'Intel',
        AuthenticAMD => 'AMD',
        TMx86        => 'Transmeta',
        TransmetaCPU => 'Transmeta',
        CyrixInstead => 'Cyrix',
        CentaurHauls => 'VIA'
    );

    if (exists $manufacturers{$manufacturer}) {
        $manufacturer = $manufacturers{$manufacturer};
    } elsif ($manufacturer =~ /(
        maxtor    |
        sony      |
        compaq    |
        ibm       |
        toshiba   |
        fujitsu   |
        lg        |
        samsung   |
        nec       |
        transcend |
        matshita  |
        hitachi   |
        pioneer
    )/xi) {
        $manufacturer = ucfirst(lc($1));
    } elsif ($manufacturer =~ /^(hp|HP|(?i)hewlett[ -]packard)/) {
        $manufacturer = "Hewlett-Packard";
    } elsif ($manufacturer =~ /^(WDC|(?i)western)/) {
        $manufacturer = "Western Digital";
    } elsif ($manufacturer =~ /^(ST|(?i)seagate)/) {
        $manufacturer = "Seagate";
    } elsif ($manufacturer =~ /^(HD|IC|HU|HGST)/) {
        $manufacturer = "Hitachi";
    }

    return $manufacturer;
}

sub getCanonicalSpeed {
    my ($speed) = @_;

    ## no critic (ExplicitReturnUndef)

    return undef unless $speed;

    return 400 if $speed =~ /^PC3200U/;

    return undef unless $speed =~ /^([,.\d]+) \s? (\S+)$/x;
    my $value = $1;
    my $unit = lc($2);

    return
        $unit eq 'ghz' ? $value * 1000 :
        $unit eq 'mhz' ? $value        :
                         undef         ;
}

sub getCanonicalInterfaceSpeed {
    # Expected unit is Mb/s as specified in inventory protocol
    my ($speed) = @_;

    ## no critic (ExplicitReturnUndef)

    return undef unless $speed;

    return undef unless $speed =~ /^([,.\d]+) \s? (\S\S)\S*$/x;
    my $value = $1;
    my $unit = lc($2);

    return
        $unit eq 'gb' ? $value * 1000         :
        $unit eq 'mb' ? $value                :
        $unit eq 'kb' ? int($value / 1000)    :
                        undef                 ;
}

sub getCanonicalSize {
    my ($size, $base) = @_;
    $base ||= 1000;

    ## no critic (ExplicitReturnUndef)

    return undef unless $size;

    return $size if $size =~ /^\d+$/;

    $size =~ s/ //g;

    return undef unless $size =~ /^([,.\d]+) (\S+)$/x;
    my $value = $1;
    my $unit = lc($2);

    return
        $unit eq 'tb'    ? $value * $base * $base        :
        $unit eq 'gb'    ? $value * $base                :
        $unit eq 'mb'    ? $value                        :
        $unit eq 'kb'    ? int($value / ($base))         :
        $unit eq 'bytes' ? int($value / ($base * $base)) :
                           undef                         ;
}

sub compareVersion {
    my ($major, $minor, $min_major, $min_minor) = @_;

    $major = 0 unless $major;
    $minor = 0 unless $minor;
    $min_major = 0 unless $min_major;
    $min_minor = 0 unless $min_minor;

    return
        $major > $min_major
        ||
        (
            $major == $min_major
            &&
            $minor >= $min_minor
        );
}

sub getSanitizedString {
    my ($string) = @_;

    return unless defined $string;

    # clean control caracters
    $string =~ s/[[:cntrl:]]//g;

    # encode to utf-8 if needed
    if (!Encode::is_utf8($string) && $string !~ m/\A(
          [\x09\x0A\x0D\x20-\x7E]           # ASCII
        | [\xC2-\xDF][\x80-\xBF]            # non-overlong 2-byte
        | \xE0[\xA0-\xBF][\x80-\xBF]        # excluding overlongs
        | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2} # straight 3-byte
        | \xED[\x80-\x9F][\x80-\xBF]        # excluding surrogates
        | \xF0[\x90-\xBF][\x80-\xBF]{2}     # planes 1-3
        | [\xF1-\xF3][\x80-\xBF]{3}         # planes 4-15
        | \xF4[\x80-\x8F][\x80-\xBF]{2}     # plane 16
        )*\z/x) {
        $string = encode("UTF-8", $string);
    };

    return $string;
}

sub trimWhitespace {
    my ($value) = @_;
    $value =~ s/^\s+//;
    $value =~ s/\s+$//;
    $value =~ s/\s+/ /g;
    return $value;
}

sub getDirectoryHandle {
    my (%params) = @_;

    die "no directory parameter given" unless $params{directory};

    my $handle;

    if (!opendir $handle, $params{directory}) {
        $params{logger}->error("Can't open directory $params{directory}: $ERRNO")
            if $params{logger};
        return;
    }

    return $handle;
}

sub getFileHandle {
    my (%params) = @_;

    my $handle;

    SWITCH: {
        if ($params{file}) {
            if (!open $handle, '<', $params{file}) {
                $params{logger}->error(
                    "Can't open file $params{file}: $ERRNO"
                ) if $params{logger};
                return;
            }
            last SWITCH;
        }
        if ($params{command}) {
            # FIXME: 'Bad file descriptor' error message on Windows
            $params{logger}->debug2("executing $params{command}")
                if $params{logger};
            # Turn off localised output for commands
            local $ENV{LC_ALL} = 'C';
            local $ENV{LANG} = 'C';
            # Ignore 'Broken Pipe' warnings on Solaris
            local $SIG{PIPE} = 'IGNORE' if $OSNAME eq 'solaris';
            if (!open $handle, '-|', $params{command} . " 2>$nowhere") {
                $params{logger}->error(
                    "Can't run command $params{command}: $ERRNO"
                ) if $params{logger};
                return;
            }
            last SWITCH;
        }
        if ($params{string}) {
            open $handle, "<", \$params{string} or die;
            last SWITCH;
        }
        die "neither command, file or string parameter given";
    }

    return $handle;
}

sub getFirstLine {
    my (%params) = @_;

    my $handle = getFileHandle(%params);
    return unless $handle;

    my $result = <$handle>;
    close $handle;

    chomp $result if $result;
    return $result;
}

sub getLastLine {
    my (%params) = @_;

    my $handle = getFileHandle(%params);
    return unless $handle;

    my $result;
    while (my $line = <$handle>) {
        $result = $line;
    }
    close $handle;

    chomp $result if $result;
    return $result;
}

sub getFirstMatch {
    my (%params) = @_;

    return unless $params{pattern};
    my $handle = getFileHandle(%params);
    return unless $handle;

    my @results;
    while (my $line = <$handle>) {
        @results = $line =~ $params{pattern};
        last if @results;
    }
    close $handle;

    return wantarray ? @results : $results[0];
}

sub getAllLines {
    my (%params) = @_;

    my $handle = getFileHandle(%params);
    return unless $handle;

    if (wantarray) {
        my @lines = map { chomp; $_ } <$handle>;
        close $handle;
        return @lines;
    } else {
        local $RS;
        my $lines = <$handle>;
        close $handle;
        return $lines;
    }
}

sub getLinesCount {
    my (%params) = @_;

    my $handle = getFileHandle(%params);
    return unless $handle;

    my $count = 0;
    while (my $line = <$handle>) {
        $count++;
    }
    close $handle;

    return $count;
}

sub canRun {
    my ($binary) = @_;

    return $binary =~ m{^/} ?
        -x $binary :            # full path
        scalar(which($binary)); # executable name
}

sub hex2char {
    my ($value) = @_;

    ## no critic (ExplicitReturnUndef)
    return undef unless $value;
    return $value unless $value =~ /^0x/;

    $value =~ s/^0x//; # drop hex prefix
    return pack('H*', $value);
}

sub hex2dec {
    my ($value) = @_;

    ## no critic (ExplicitReturnUndef)
    return undef unless $value;
    return $value unless $value =~ /^0x/;

    return oct($value);
}

sub dec2hex {
    my ($value) = @_;

    ## no critic (ExplicitReturnUndef)
    return undef unless $value;
    return $value if $value =~ /^0x/;

    return sprintf("0x%x", $value);
}

# shamelessly imported from List::MoreUtils to avoid a dependency
sub any (&@) { ## no critic (SubroutinePrototypes)
    my $f = shift;
    foreach ( @_ ) {
        return 1 if $f->();
    }
    return 0;
}

sub all (&@) { ## no critic (SubroutinePrototypes)
    my $f = shift;
    foreach ( @_ ) {
        return 0 unless $f->();
    }
    return 1;
}

sub none (&@) { ## no critic (SubroutinePrototypes)
    my $f = shift;
    foreach ( @_ ) {
        return 0 if $f->();
    }
    return 1;
}

sub uniq (@) { ## no critic (SubroutinePrototypes)
    my %seen = ();
    grep { not $seen{$_}++ } @_;
}

sub file2module {
    my ($file) = @_;
    $file =~ s{.pm$}{};
    $file =~ s{/}{::}g;
    return $file;
}

sub module2file {
    my ($module) = @_;
    $module .= '.pm';
    $module =~ s{::}{/}g;
    return $module;
}

sub runFunction {
    my (%params) = @_;

    my $logger = $params{logger};

    # ensure module is loaded
    if ($params{load}) {
        $params{module}->require();
        if ($EVAL_ERROR) {
            $logger->debug("Failed to load $params{module}: $EVAL_ERROR")
                if $logger;
            return;
        }
    }

    my $result;
    eval {
        local $SIG{ALRM} = sub { die "alarm\n" };
        # set a timeout if needed
        alarm $params{timeout} if $params{timeout};

        no strict 'refs'; ## no critic (ProhibitNoStrict)
        $result = &{$params{module} . '::' . $params{function}}(
            ref $params{params} eq 'HASH'  ? %{$params{params}} :
            ref $params{params} eq 'ARRAY' ? @{$params{params}} :
                                               $params{params}
        );
        alarm 0;
    };

    if ($EVAL_ERROR) {
        my $message = $EVAL_ERROR eq "alarm\n" ?
            "$params{module} killed by a timeout"             :
            "unexpected error in $params{module}: $EVAL_ERROR";
        $logger->debug($message) if $logger;
    }

    return $result;
}

sub delay {
    my ($delay) = @_;

    if ($OSNAME eq 'MSWin32') {
        Win32->require();
        Win32::Sleep($delay*1000);
    }  else {
        sleep($delay);
    }
}

sub slurp {
    my($file) = @_;

    my $handler;
    return unless open $handler, '<', $file;
    local $INPUT_RECORD_SEPARATOR; # Set input to "slurp" mode.
    my $content = <$handler>;
    close $handler;
    return $content;
}

sub isParamArrayAndFilled {
    my ($hash, $paramName) = @_;

    return (defined ($hash->{$paramName}))
            && UNIVERSAL::isa($hash->{$paramName}, 'ARRAY')
            && (scalar(@{$hash->{$paramName}}) > 0);
}

1;
__END__