package FusionInventory::Agent::Tools::Solaris;

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

use English qw(-no_match_vars);

use FusionInventory::Agent::Tools;
use Memoize;

our @EXPORT = qw(
    getZone
    getPrtconfInfos
    getPrtdiagInfos
);

memoize('getZone');
memoize('getPrtconfInfos');
memoize('getPrtdiagInfos');

sub getZone {
    return canRun('zonename') ?
        getFirstLine(command => 'zonename') : # actual zone name
        'global';                             # outside zone name
}

sub getPrtconfInfos {
    my (%params) = (
        command => '/usr/sbin/prtconf -vp',
        @_
    );

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

    my $info = {};

    # a stack of nodes, as a list of couples [ node, level ]
    my @parents = (
        [ $info, -1 ]
    );

    while (my $line = <$handle>) {
        chomp $line;

        # new node
        if ($line =~ /^(\s*)Node \s (0x[a-f\d]+)/x) {
            my $level   = defined $1 ? length($1) : 0;
            my $address = $2;

            my $parent_level = $parents[-1]->[1];

            # compare level with parent
            if ($level > $parent_level) {
                # down the tree: no change
            } elsif ($level < $parent_level) {
                # up the tree: unstack nodes until a suitable parent is found
                while ($level <= $parents[-1]->[1]) {
                    pop @parents;
                }
            } else {
                # same level: unstack last node
                pop @parents;
            }

            # attach a new node to parent node
            my $parent_node = $parents[-1]->[0];
            $parent_node->{$address} = {};

            # and push it to the stack
            push (@parents, [ $parent_node->{$address}, $level ]);

            next;
        }

        # value
        if ($line =~ /(\S[^:]+): \s+ (\S.*)$/x) {
            my $key       = $1;
            my $raw_value = $2;
            my $node = $parents[-1]->[0];

            if ($raw_value =~ /^'[^']+'(?: \+ '[^']+')+$/) {
                # list of string values
                $node->{$key} = [
                    map { /^'([^']+)'$/; $1 }
                    split (/ \+ /, $raw_value)
                ];
            } elsif ($raw_value =~ /^'([^']+)'$/) {
                # single string value
                $node->{$key} = $1;
            } else  {
                # other kind of value
                $node->{$key} = $raw_value;
            }
            next;
        }

    }
    close $handle;

    return $info;
}

sub getPrtdiagInfos {
    my (%params) = (
        command => 'prtdiag',
        @_
    );

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

    my $info = {};

    while (my $line = <$handle>) {
        next unless $line =~ /^=+ \s ([\w\s]+) \s =+$/x;
        my $section = $1;
        $info->{memories} = _parseMemorySection($section, $handle)
            if $section =~ /Memory/;
        $info->{slots}  = _parseSlotsSection($section, $handle)
            if $section =~ /(IO|Slots)/;
    }
    close $handle;

    return $info;
}

sub _parseMemorySection {
    my ($section, $handle) = @_;

    my ($offset, $callback);

    SWITCH: {
        if ($section eq 'Physical Memory Configuration') {
            my $i = 0;
            $offset = 5;
            $callback = sub {
                my ($line) = @_;
                return unless $line =~ qr/
                    (\d+ \s [MG]B) \s+
                    \S+
                $/x;
                return {
                    NUMSLOTS => $i++,
                    CAPACITY => getCanonicalSize($1)
                };
            };
            last SWITCH;
        }

        if ($section eq 'Memory Configuration') {
            # use next line to determine actual format
            my $next_line = <$handle>;

            if ($next_line =~ /^Segment Table/) {
                # multi-table format: reach bank table
                while ($next_line = <$handle>) {
                    last if $next_line =~ /^Bank Table/;
                }

                # then parse using callback
                my $i = 0;
                $offset = 4;
                $callback = sub {
                    my ($line) = @_;
                    return unless $line =~ qr/
                        \d+         \s+
                        \S+         \s+
                        \S+         \s+
                        (\d+ [MG]B)
                    /x;
                    return {
                        NUMSLOTS => $i++,
                        CAPACITY => getCanonicalSize($1)
                    };
                };
            } else {
                # single-table format: start using callback directly
                my $i = 0;
                $offset = 4;
                $callback = sub {
                    my ($line) = @_;
                    return unless $line =~ qr/
                        (\d+ [MG]B) \s+
                        \S+         \s+
                        (\d+ [MG]B) \s+
                        \S+         \s+
                        \d
                    $/x;
                    return {
                        NUMSLOTS => $i++,
                        CAPACITY => getCanonicalSize($1)
                    };
                };
            }

            last SWITCH;
        }

        if ($section eq 'Memory Device Sockets') {
            my $i = 0;
            $offset = 3;
            $callback = sub {
                my ($line) = @_;
                return unless $line =~ qr/^
                    (\w+)           \s+
                    in \s use       \s+
                    \d              \s+
                    \w+ (?:\s \w+)*
                /x;
                return {
                    NUMSLOTS => $i++,
                    TYPE     => $1
                };
            };
            last SWITCH;
        }

        return;
    }

    return _parseAnySection($handle, $offset, $callback);
}

sub _parseSlotsSection {
    my ($section, $handle) = @_;

    my ($offset, $callback);

    SWITCH: {
        if ($section eq 'IO Devices') {
            $offset  = 3;
            $callback = sub {
                my ($line) = @_;
                return unless $line =~ /^
                    (\S+)    \s+
                    ([A-Z]+) \s+
                    (\S+)
                /x;
                return {
                    NAME        => $1,
                    DESCRIPTION => $2,
                    DESIGNATION => $3,
                };
            };
            last SWITCH;
        }

        if ($section eq 'IO Cards') {
            $offset  = 7;
            $callback = sub {
                my ($line) = @_;
                return unless $line =~ /^
                    \S+      \s+
                    ([A-Z]+) \s+
                    \S+      \s+
                    \S+      \s+
                    (\d)     \s+
                    \S+      \s+
                    \S+      \s+
                    \S+      \s+
                    \S+      \s+
                    (\S+)
                /x;
                return {
                    NAME        => $2,
                    DESCRIPTION => $1,
                    DESIGNATION => $3,
                };
            };
            last SWITCH;
        }

        if ($section eq 'Upgradeable Slots') {
            $offset  = 3;
            # use a column-based strategy, as most values include spaces
            $callback = sub {
                my ($line) = @_;

                my $name        = substr($line, 0, 1);
                my $status      = substr($line, 4, 9);
                my $description = substr($line, 14, 16);
                my $designation = substr($line, 31, 28);

                $status      =~ s/\s+$//;
                $description =~ s/\s+$//;
                $designation =~ s/\s+$//;

                $status =
                    $status eq 'in use'    ? 'used' :
                    $status eq 'available' ? 'free' :
                                              undef;

                return {
                    NAME        => $name,
                    STATUS      => $status,
                    DESCRIPTION => $description,
                    DESIGNATION => $designation,
                };
            };
            last SWITCH;
        }

        return;
    };

    return _parseAnySection($handle, $offset, $callback);
}

sub _parseAnySection {
    my ($handle, $offset, $callback) = @_;

    # skip headers
    foreach my $i (1 .. $offset) {
        <$handle>;
    }

    # parse content
    my @items;
    while (my $line = <$handle>) {
        last if $line =~ /^$/;
        chomp $line;
        my $item = $callback->($line);
        push @items, $item if $item;
    }

    return \@items;
}

1;
__END__

=head1 NAME

FusionInventory::Agent::Tools::Solaris - Solaris generic functions

=head1 DESCRIPTION

This module provides some generic functions for Solaris.

=head1 FUNCTIONS

=head2 getZone()

Returns current zone name, or 'global' if there is no defined zone.

=head2 getModel()

Returns system model, as a string.

=head2 getclass()

Returns system class, as a symbolic constant.

=head2 getPrtconfInfos(%params)

Returns a structured view of prtconf output. Each information block is
turned into a hashref, hierarchically organised.

$info = {
    'System Configuration' => 'Sun Microsystems  sun4u',
    'Memory size' => '32768 Megabytes',
    '0xf00298fc' => {
        'banner-name' => 'Sun Fire V890',
        'model' => 'SUNW,501-7199',
        '0xf007c538' => {
            'compatible' => [
                'SUNW,UltraSPARC-III,mc',
                'SUNW,mc'
            ],
        }
    }
}