#! /usr/perl5/bin/perl
#
# CDDL HEADER START
#
# The contents of this file are subject to the terms of the
# Common Development and Distribution License (the "License").
# You may not use this file except in compliance with the License.
#
# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
# or http://www.opensolaris.org/os/licensing.
# See the License for the specific language governing permissions
# and limitations under the License.
#
# When distributing Covered Code, include this CDDL HEADER in each
# file and include the License file at usr/src/OPENSOLARIS.LICENSE.
# If applicable, add the following below this CDDL HEADER, with the
# fields enclosed by brackets "[]" replaced with your own identifying
# information: Portions Copyright [yyyy] [name of copyright owner]
#
# CDDL HEADER END
#
#
# Copyright 2008 Sun Microsystems, Inc. All rights reserved.
# Use is subject to license terms.
#
# ident "%Z%%M% %I% %E% SMI"
#
require 5.8.0;
use strict;
use warnings;
# Make sure that Lgrp test is not executed on anything less than 5.8.0,
# as Lgrp is not implemented there
BEGIN {
if ($] < 5.008) {
# Fake one successfull test and exit
printf "1..1\nok\n";
exit 0;
}
}
######################################################################
# Tests for Sun::Solaris::Lgrp API.
#
# This is an example script that demonstrates use of Sun::Solaris::Lgrp module.
# It can be used to test the module itself, the liblgrp library or the in-kernel
# implementation.
######################################################################
# Tests to run
use Test::More tests => 33;
# Verify that we can load the module
BEGIN { use_ok('Sun::Solaris::Lgrp') };
use Sun::Solaris::Lgrp ':ALL';
my ($home, $fail);
######################################################################
# Verify that lgrp_init() works.
##
my $c = Sun::Solaris::Lgrp->new(LGRP_VIEW_OS);
ok($c, 'lgrp_init') or die("lgrp_init: $!");
#
######################################################################
######################################################################
# root should have ID 0.
##
my $root = $c->root;
is($root, 0, 'root should have id zero');
#
######################################################################
# Verify lgrp_nlgrps()
##
my $nlgrps = $c->nlgrps;
ok($nlgrps, 'lgrp_nlgrps') or
diag("lgrp_nlgrps: $!");
my $is_numa = ($nlgrps > 1);
my @lgrps = $c->lgrps;
ok(scalar @lgrps, 'Can get lgrps list') or
diag("lgrp_lgrps: $!");
is(scalar @lgrps, $nlgrps, 'lgrp_nlgrps() should match number of lgrps');
######################################################################
# All root children should have root as their one and only one parent
##
$fail = 0;
my (@children) = $c->children($root);
my @leaves = $c->leaves;
ok(@leaves, 'There are some leaves');
cmp_ok(@children, '<=', @leaves, 'Root should have nchildren <= nleaves');
my @parents;
foreach my $l (@children) {
(@parents) = $c->parents($l) or
diag("lgrp_parents: $!");
my $nparents = @parents;
my ($parent, @rest) = @parents;
$fail++ if $parent != $root;
$fail++ unless $nparents == 1;
}
is($fail, 0, 'correct parents for children');
######################################################################
# Each lgrp other than root should have a single parent and
# root should have no parents.
##
$fail = 0;
foreach my $l (lgrp_lgrps($c)) {
next if $l == $root;
my (@parents) = $c->parents($l) or
diag("lgrp_parents: $!");
my $nparents = @parents;
$fail++ unless $nparents == 1;
}
is($fail, 0, 'All non-leaf lgrps should have single parent');
@parents = $c->parents($root);
ok(!@parents, 'root should have no parents');
#
#######################################################################
######################################################################
# Lgrp affinity tests.
#######################
######################################################################
# lgrp_affinity-set should change home lgrp.
##
SKIP: {
skip 'Test only valid on NUMA platform', 1 unless $is_numa;
my $leaf = $leaves[0]; # Pickup any non-root lgrp.
$home = $c->home(P_PID, P_MYID);
# Pickup any lgrp not equal to the current one.
my $lgrp = ($home == $root ? $leaf : $root);
# Set affinity to the new lgrp.
$c->affinity_set(P_PID, P_MYID, $lgrp, LGRP_AFF_STRONG) or
diag("lgrp_affinity_set(): $!");
# Our home should change to a new lgrp.
$home = $c->home(P_PID, P_MYID);
is($home, $lgrp, 'Home lgrp should change after strong affinity is set');
# Drop affinity to the lgrp.
$c->affinity_set(P_PID, P_MYID, $lgrp, LGRP_AFF_NONE) or
diag("lgrp_affinity_set(): $!");
}
######################################################################
# Should be able to set affinity to any legal value
##
my @affs = (LGRP_AFF_WEAK, LGRP_AFF_STRONG, LGRP_AFF_NONE);
foreach my $aff (@affs) {
$c->affinity_set(P_PID, P_MYID, $root, $aff) or
diag("lgrp_affinity_set(): $!");
my $affinity = $c->affinity_get(P_PID, $$, $root);
is($affinity, $aff, "affinity should be $aff");
}
#
######################################################################
######################################################################
# Root should have non-zero CPUs and memory size
# Also, its memory size should be consistent with the one reported by
# sysconfig.
##
my @rcpus = $c->cpus($root, LGRP_CONTENT_HIERARCHY) or
die("lgrp_cpus: $!");
my $ncpus = @rcpus;
ok($ncpus, 'there are CPUs in the system');
my $memsize = $c->mem_size($root,
LGRP_MEM_SZ_INSTALLED,
LGRP_CONTENT_HIERARCHY) or
diag("lgrp_mem_size(): $!");
ok($memsize, 'memory size is non-zero');
#
######################################################################
######################################################################
# The cookie should not be stale
is($c->stale, 0, 'Cookie should not be stale');
#
######################################################################
######################################################################
# Latency should be non-zero.
my $latency = lgrp_latency($root, $root);
ok(defined $latency, 'lgrp_latency() is working') or
diag("lgrp_latency: $!");
my $latency1 = $c->latency($root, $root);
ok(defined $latency1, 'lgrp_latency_cookie() is working') or
diag("lgrp_latency_cookie: $!");
is($latency, $latency1, 'Latencies should match');
#
######################################################################
######################################################################
# Verify latency matrix.
##
SKIP: {
skip 'Test only valid on NUMA platform', 9 unless $is_numa;
cmp_ok($latency, '>', 0, "Latency from root to self should be positive");
my $latencies;
my $min_latency = 10000;
my $max_latency = 0;
my $badlatency = 0;
my $assymetrical = 0;
my $diagonalmin = 0;
my $badself = 0;
my $nlatencies;
foreach my $l1 (@lgrps) {
foreach my $l2 (@lgrps) {
$latencies->{$l1}{$l2} = $c->latency($l1, $l2);
$nlatencies++ if $latencies->{$l1}{$l2};
}
}
# There should be at least some lgroups which have latencies.
my @d_lgrps = grep { defined $latencies->{$_}{$_} } @leaves;
ok(@d_lgrps, 'There should be at least some lgroups which have latencies');
# All diagonal latencies should be the same.
my $lat_diag_lgrp = $d_lgrps[0];
my $lat_diag = $latencies->{$lat_diag_lgrp}{$lat_diag_lgrp};
my @badlatencies = grep { $latencies->{$_}{$_} != $lat_diag } @d_lgrps;
is(scalar @badlatencies, 0, 'All diagonal latencies should be the same') or
diag("diagonal latency: $lat_diag; bad latencies: @badlatencies");
my %l_cpus;
my %l_mem;
my $lgrps_nomem;
my $lgrps_nocpus;
foreach my $l1 (@lgrps) {
$l_cpus{$l1} = scalar $c->cpus($l1, LGRP_CONTENT_HIERARCHY);
$l_mem{$l1} = $c->mem_size($l1, LGRP_MEM_SZ_INSTALLED,
LGRP_CONTENT_HIERARCHY);
$lgrps_nomem++ unless $l_mem{$l1};
$lgrps_nocpus++ unless $c->cpus($l1, LGRP_CONTENT_HIERARCHY);
}
# Verify latencies consistency
foreach my $l1 (@lgrps) {
# Can't get latency if source doesn't have CPUs
next unless $l_cpus{$l1};
my $self_latency = $latencies->{$l1}{$l1};
$lat_diag = $self_latency if $self_latency;
foreach my $l2 (@lgrps) {
# Can't get latenciy if destination doesn't have memory
next unless $l_mem{$l2};
if (! $latencies->{$l1}{$l2}) {
$badlatency++;
diag("Invalid latency between $l1 and $l2");
next;
}
$max_latency = $latencies->{$l1}{$l2} if
$latencies->{$l1}{$l2} > $max_latency;
$min_latency = $latencies->{$l1}{$l2} if
$latencies->{$l1}{$l2} < $min_latency;
# Latencies should be symmetrical but only if they are valid.
if ($latencies->{$l2}{$l1} &&
$latencies->{$l1}{$l2} != $latencies->{$l2}{$l1}) {
$assymetrical++;
diag("latency($l1, $l2) != latency($l2, $l1)");
}
$diagonalmin++ if $c->isleaf($l1) && $c->isleaf($l2) &&
$self_latency && $self_latency > $latencies->{$l1}{$l2};
}
}
SKIP: {
skip 'Symmetry test only valid if all lgroups have memory and CPUs',
1 if $lgrps_nomem || $lgrps_nocpus;
is($assymetrical, 0, 'Latencies should be symmetrical');
}
is($diagonalmin, 0, 'Latency should be minimal on diagonals');
is($badlatency, 0, 'Latency should be defined');
is($max_latency, $latencies->{$root}{$root},
'Root should have maximum latencies');
cmp_ok($min_latency, '>', 0, 'Minimum latency should be positive') if
$nlatencies;
cmp_ok($min_latency, '<=', $max_latency,
'Minimum latency should be less then maximum') if $nlatencies;
}
######################################################################
# Verify lgrp_resources API
##
SKIP: {
skip 'lgrp_resources() is not supported', 3 if
((LGRP_VER_CURRENT == 1) || !$is_numa);
my @lgrps_c = $c->resources($root, LGRP_RSRC_CPU);
ok(scalar @lgrps_c, 'there are CPU resources in the system');
$fail = 0;
my $nc = 0;
foreach my $l (@lgrps_c) {
$fail++ unless $c->isleaf($l);
my @cpu_l = $c->cpus($l, LGRP_CONTENT_DIRECT);
$nc += @cpu_l;
}
is($fail, 0, 'Each lgrp containing CPU resources should be leaf');
is($nc, $ncpus, 'Number of CPUs should match');
}
#
######################################################################
# THE END!
#########