File Coverage

blib/lib/FusionInventory/Agent/Tools.pm

Criterion	Covered	Total	%
statement	209	243	86.0
branch	105	152	69.0
condition	6	8	75.0
subroutine	38	43	88.3
pod	29	29	100.0
total	387	475	81.4

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

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

1;
__END__