#!/usr/perl5/bin/perl

#
# Copyright 2005 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#
# CDDL HEADER START
#
# The contents of this file are subject to the terms of the
# Common Development and Distribution License, Version 1.0 only
# (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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#
#ident	"@(#)lgrpinfo.pl	1.93	06/05/26 SMI"
#
# lgrpinfo: display information about locality groups.
#

require 5.6.1;
use warnings;
use strict;
use Getopt::Long qw(:config no_ignore_case bundling auto_version);
use File::Basename;
# Sun::Solaris::Kstat is used to extract per-lgroup load average.
use Sun::Solaris::Kstat;
use POSIX qw(locale_h);
use Sun::Solaris::Utils qw(textdomain gettext);
use Solaris::Lgrp ':CONSTANTS';

use constant LGRP_LOADAVG_THREAD_MAX => 65516;

# Get script name
our $cmdname = basename($0, ".pl");

# Get liblgrp version
my $version = Solaris::Lgrp::lgrp_version();

our $VERSION = "1.93 (liblgrp version $version)";

# The $loads hash keeps per-lgroup load average.
my %loads;

########################################
# Main body
##

# Set message locale
setlocale(LC_ALL, "");
textdomain("SUNW_OST_OSCMD");

# Parse command-line options
our($opt_a, $opt_l, $opt_m, $opt_c, $opt_C, $opt_e, $opt_t, $opt_h, $opt_u,
    $opt_r, $opt_L, $opt_P, $opt_I, $opt_T, $opt_G);

GetOptions("a"   => \$opt_a,
	   "c"   => \$opt_c,
	   "C"	 => \$opt_C,
	   "e"	 => \$opt_e,
	   "G"	 => \$opt_G,
	   "h|?" => \$opt_h,
	   "l"   => \$opt_l,
	   "L"	 => \$opt_L,
	   "I"   => \$opt_I,
	   "m"   => \$opt_m,
	   "r"   => \$opt_r,
	   "t"	 => \$opt_t,
	   "T"   => \$opt_T,
	   "u=s" => \$opt_u,
	   "P"   => \$opt_P) || usage(3);

usage(0) if $opt_h;

# Check for conflicting options
my $nfilters = 0;
$nfilters++ if $opt_C;
$nfilters++ if $opt_P;
$nfilters++ if $opt_T;

if ($nfilters > 1) {
	printf STDERR
	  gettext("%s: Options -C, -T and -P can not be used together\n"),
	    $cmdname;
	usage(3);
}

if ($opt_T && ($opt_I || $opt_t)) {
	printf STDERR
	  gettext("%s: Option -T can not be used with -I, -t\n"),
	    $cmdname;
	usage(3);
}

if ($opt_T && scalar @ARGV) {
	printf STDERR
	  gettext("%s: Warning: with '-T' all lgroups on the command line "),
	    $cmdname;
	printf STDERR gettext("are ignored\n\n");
}

if ($opt_L && $opt_I) {
	printf STDERR gettext("%s: Option -I can not be used with -L\n"),
	  $cmdname;
	usage(3);
}

# Figure out what to do base on options
my $do_default = 1 unless
  $opt_a || $opt_l || $opt_m || $opt_c || $opt_e || $opt_t || $opt_u ||
  $opt_r;


my $l =  Solaris::Lgrp->new($opt_G ? LGRP_VIEW_OS : LGRP_VIEW_CALLER) or
    die(gettext("$cmdname: can not get lgroup information from the system\n"));


# Get list of all lgroups, the root and the list of intermediates
my @lgrps = nsort($l->lgrps);
my $root = $l->root;
my @intermediates = grep { $_ != $root && !$l->isleaf($_) } @lgrps;
my $is_uma = (scalar @lgrps == 1);

# Print everything if -a is specified or it is default without -T
my $do_all    = 1 if $opt_a  || ($do_default && !($opt_T || $opt_L));

# Print individual information if do_all or requested specific print
my $do_lat    = 1 if $do_all || $opt_l;
my $do_memory = 1 if $do_all || $opt_m || $opt_u;
my $do_cpu    = 1 if $do_all || $opt_c;
my $do_topo   = 1 if $do_all || $opt_t;
my $do_rsrc   = 1 if $do_all || $opt_r;
my $do_load   = 1 if $do_all || $opt_e;
my $do_table  = 1 if $opt_a  || $opt_L;
my $do_something = ($do_lat || $do_memory || $do_cpu || $do_topo ||
		    $do_rsrc || $do_load);

# Does the liblgrp(3LIB) has enough capabilities to support resource view?
if ($do_rsrc && LGRP_VER_CURRENT == 1) {
	if ($opt_r) {
		printf STDERR
		  gettext("%s: sorry, your system does not support"),
		    $cmdname;
		printf STDERR " lgrp_resources(3LGRP)\n";
	}
	$do_rsrc = 0;
}

# Get list of lgrps from arguments, expanding symbolic names like
# "root" and "leaves"
# Use all lgroups if none are specified on the command line
my @lgrp_list = scalar @ARGV ? lgrp_expand($l, @ARGV) : @lgrps;

# Apply 'Parent' or 'Children' operations if requested
@lgrp_list = map { $l->parents($_)  }     @lgrp_list if $opt_P;
@lgrp_list = map { $l->children($_) }     @lgrp_list if $opt_C;

# Drop repeating elements and sort lgroups numerically.
@lgrp_list = uniqsort(@lgrp_list);

# If both -L and -c are specified, just print list of CPUs.
if ($opt_c && $opt_I) {
	my @cpus = uniqsort(map { $l->cpus($_, LGRP_CONTENT_HIERARCHY) }
			    @lgrp_list);
	print "@cpus\n";
	exit(0);
}

# Units is Mb by default */
my $unit_str = "Mb";
my $units = 1024 * 1024;

# Convert units to canonical numeric and string formats.
if ($opt_u) {
	if ($opt_u =~ /^b/i) {
		$units = 1;
		$unit_str = "Bytes";
	} elsif ($opt_u =~ /^k/i) {
		$units = 1024;
		$unit_str = "Kb";
	} elsif ($opt_u =~ /^g/i) {
		$units *= 1024;
		$unit_str = "Gb";
	} elsif ($opt_u =~ /^t/i) {
		$units *= 1024 * 1024;
		$unit_str = "Tb";
	} elsif (! ($opt_u =~ /^m/i)) {
		printf STDERR
		  gettext("%s: invalid unit '$opt_u', should be [b|k|m|g|t]"),
		    $cmdname;
		printf STDERR gettext(", using Mb.\n\n");
	}
}

# Collect load average data if requested.
if ($do_load) {
	my $ks = Sun::Solaris::Kstat->new(strip_strings => 1) or
	  die(gettext("$cmdname: kstat_open() failed: %!\n"));

	my $lgrp_kstats = $ks->{lgrp} or
	  die(gettext("$cmdname: can not read lgrp kstat\n)"));

	foreach my $i (keys %$lgrp_kstats) {
		my $info = $lgrp_kstats->{$i};
		my $lav = $lgrp_kstats->{$i}->{"lgrp$i"}->{"load average"};
		my @cpus = $l->cpus($i, LGRP_CONTENT_DIRECT);
		my $ncpus = @cpus;
		$lav = $ncpus ? $lav / (LGRP_LOADAVG_THREAD_MAX / $ncpus) : 0;
		# Loads are integers multiplied by 100
		$loads{$i} = sprintf (gettext("Load: %4.3g"), $lav);
	}
}

# Get latency values for each lgroup.
my %self_latencies;
map { $self_latencies{$_} = $l->latency($_, $_) } @lgrps;

# If -T is specified, just print topology and return.
if ($opt_T) {
	lgrp_prettyprint($l);
	print_latency_table(\@lgrps, \@lgrps) if $do_table;
	exit(0);
}

if (!scalar @lgrp_list) {
	printf STDERR gettext("%s: No matching lgroups found!\n"), $cmdname;
	exit(2);
}

# Just print list of lgrps if doing just filtering
(print "@lgrp_list\n"), exit 0 if $opt_I;

if ($do_something) {
	# Walk through each requested lgrp and print whatever is requested.
	foreach my $lgrp (@lgrp_list) {
		my $is_leaf = $l->isleaf($lgrp);
		my ($children, $parents, $cpus, $memstr, $rsrc);

		my $prefix = ($lgrp == $root) ?
		  "root": $is_leaf ? gettext("leaf") : gettext("intermediate");
		printf gettext("lgroup %d (%s):"), $lgrp, $prefix;

		if ($do_topo) {
			# Get children of this lgrp.
			my @children = $l->children($lgrp);
			$children = $is_leaf ?
			  gettext("Children: none") :
			    gettext("Children: ") . lgrp_collapse(@children);
			# Are there any parents for this lgrp?
			my @parents = $l->parents($lgrp);
			$parents = @parents ?
			  gettext(", Parent: ") . "@parents" :
			    "";
		}

		if ($do_cpu) {
			$cpus = lgrp_showcpus($lgrp, LGRP_CONTENT_HIERARCHY);
		}
		if ($do_memory) {
			$memstr = lgrp_showmemory($lgrp, LGRP_CONTENT_HIERARCHY);
		}
		if ($do_rsrc) {
			$rsrc = lgrp_showresources($lgrp);
		}

		# Print all the information about lgrp.
		print "\n\t$children$parents"	if $do_topo;
		print "\n\t$cpus"		if $do_cpu && $cpus;
		print "\n\t$memstr"		if $do_memory && $memstr;
		print "\n\t$rsrc"		if $do_rsrc;
		print "\n\t$loads{$lgrp}"	if defined ($loads{$lgrp});
		if ($do_lat && defined($self_latencies{$lgrp})) {
		    printf gettext("\n\tLatency: %d"), $self_latencies{$lgrp};
		}
		print "\n";
	}
}

print_latency_table(\@lgrps, \@lgrp_list) if $do_table;

exit 0;

#
# usage(exit_status)
# print usage message and exit with the specified exit status.
#
sub usage
{
	printf STDERR
  gettext("Usage:\t%s [-aceGhIlLmrt] [-u unit] [-C|-P] lgrp ...\n"),
	    $cmdname;
	printf STDERR
  gettext("      \t%s -T [-aceGhIlLmr] [-u unit]\n\n"), $cmdname;

	printf STDERR
  gettext("   Display information about locality groups\n\n") .
  gettext("\t-a: Equivalent to \"%s\" without -T and to \"%s\" with -T\n"),
    "-celLmrt", "-celLmr";

	print STDERR
  gettext("\t-c: Print CPU information\n"),
  gettext("\t-C: Children of the specified lgroups\n"),
  gettext("\t-e: Print lgroup load average\n"),
  gettext("\t-h: Print this message and exit\n"),
  gettext("\t-I: Print lgroup or CPU IDs only\n"),
  gettext("\t-l: Print information about lgroup latencies\n"),
  gettext("\t-G: Print OS view of lgroup hierarchy\n"),
  gettext("\t-L: Print lgroup latency table\n"),
  gettext("\t-m: Print memory information\n"),
  gettext("\t-P: Parent(s) of the specified lgroups\n"),
  gettext("\t-r: Print lgroup resources\n"),
  gettext("\t-t: Print information about lgroup topology\n"),
  gettext("\t-T: Print the hierarchy tree\n"),
  gettext("\t-u unit: Specify memory unit (b,k,m,g,t)\n\n\n");

	print STDERR
  gettext("    The lgrp may be specified as an lgroup ID,"),
  gettext(" \"root\", \"all\",\n"),
  gettext("    \"intermediate\" or \"leaves\".\n\n");

	printf STDERR
  gettext("    The default set of options is \"%s\"\n\n"),
    "-celmrt -u m all";

	print STDERR
  gettext("    Without any options print topology, CPU and memory information about each\n"),
  gettext("    lgroup. If any lgroup IDs are specified on the command line only print\n"),
  gettext("    information about the specified lgroup.\n\n");

	exit(shift);
}

# Return the input list with duplicates removed.
sub uniq
{
	my %seen;
	return (grep { ++$seen{$_} == 1 } @_);
}

#
# Sort the list numerically
# Should be called in list context
#
sub nsort
{
	return (sort { $a <=> $b } @_);
}

#
# Sort list numerically and remove duplicates
# Should be called in list context
#
sub uniqsort
{
	return (sort { $a <=> $b } uniq(@_));
}

# Round values
sub round
{
	my $val = shift;

	return (int($val + 0.5));
}

#
# Expand list of lgrps.
# 	Translate 'root' to the root lgrp id
# 	Translate 'all' to the list of all lgrps
# 	Translate 'leaves' to the list of all lgrps'
#	Translate 'intermediate' to the list of intermediates.
#
sub lgrp_expand
{
	my $lobj = shift;
	my %seen;
	my @result;

	# create a hash element for every element in @lgrps
	map { $seen{$_}++ } @lgrps;

	foreach my $lgrp (@_) {
		push(@result, $lobj->root),   next if $lgrp =~ m/^root$/i;
		push(@result, @lgrps),	      next if $lgrp =~ m/^all$/i;
		push(@result, $lobj->leaves), next if $lgrp =~ m/^leaves$/i;
		push(@result, @intermediates),
		  next if $lgrp =~ m/^intermediate$/i;
		push(@result, $lgrp),
		  next if $lgrp =~ m/^\d+$/ && $seen{$lgrp};
		printf STDERR gettext("%s: skipping invalid lgrp $lgrp\n"),
		  $cmdname;
	}

	return @result;
}

#
# lgrp_tree(class, node)
#
# Build the tree of the lgroup hierarchy starting with the specified node or
# root if no initial node is specified. Calls itself recursively specifying each
# of the children as a starting node. Builds a reference to the list with the
# node in the end and each element being a subtree.
#
sub lgrp_tree
{
	my $c = shift;
	my $lgrp = shift || $c->root;

	# Call itself for each of the children and combine results in a list.
	[ (map { lgrp_tree($c, $_) } $c->children($lgrp)), $lgrp ];
}

#
# lgrp_pp(tree, prefix, childprefix, npeers)
#
# pretty-print the hierarchy tree.
# Input Arguments:
#	Reference to the tree
#	Prefix for me to use
#	Prefix for my children to use
#	Number of peers left
#
sub lgrp_pp
{
	my $tree = shift;
	my $myprefix = shift;
	my $childprefix = shift;
	my $npeers = shift;
	my $el = pop @$tree;
	my $nchildren = scalar @$tree;
	my $printprefix = "$childprefix";
	my $printpostfix = $npeers ? "|   " : "    ";

	return unless defined ($el);

	my $bar = $npeers ? "|" : "`";
	print $childprefix ? $childprefix : "";
	print $myprefix ? "$bar" . "-- " : "";
	lgrp_print($el, "$printprefix$printpostfix");

	my $new_prefix = $npeers ? $myprefix : "    ";

	# Pretty-print the subtree with a new offset.
	map {
		lgrp_pp($_, "|   ", "$childprefix$new_prefix", --$nchildren)
	} @$tree;
}

# Pretty print the whole tree
sub lgrp_prettyprint
{
	my $c = shift;
	my $tree = lgrp_tree $c;
	lgrp_pp($tree, '', '', scalar $tree - 1);
}

sub lgrp_print
{
	my $lgrp = shift;
	my $prefix = shift;
	my ($cpus, $memstr, $rsrc);
	my $is_interm = ($lgrp != $root && !$l->isleaf($lgrp));

	print "$lgrp";

	if ($do_cpu && ($is_uma || $lgrp != $root)) {
		$cpus   = lgrp_showcpus($lgrp, LGRP_CONTENT_HIERARCHY);
	}
	if ($do_memory) {
		$memstr = lgrp_showmemory($lgrp, LGRP_CONTENT_DIRECT);
	}
	if ($do_rsrc && ($is_uma || $is_interm)) {
		$rsrc   = lgrp_showresources($lgrp) if $do_rsrc;
	}

	# Print all the information about lgrp.

	print "\n$prefix$cpus"		if $cpus;
	print "\n$prefix$memstr"	if $memstr;
	print "\n$prefix$rsrc"		if $rsrc;
	print "\n$prefix$loads{$lgrp}"	if defined ($loads{$lgrp});

	# Print latency information if requested.
	if ($do_lat && $lgrp != $root && defined($self_latencies{$lgrp})) {
		print "\n${prefix}";
		printf gettext("Latency: %d"), $self_latencies{$lgrp};
	}
	print "\n";
}

# What CPUs are in this lgrp?
sub lgrp_showcpus
{
	my $lgrp = shift;
	my $hier = shift;

	my @cpus = $l->cpus($lgrp, $hier);
	my $ncpus = @cpus;
	return 0 unless $ncpus;
	# Sort CPU list if there is something to sort.
	@cpus = nsort(@cpus) if ($ncpus > 1);
	my $cpu_string = lgrp_collapse(@cpus);
	return (($ncpus == 1) ?
		gettext("CPU: ") . $cpu_string:
		gettext("CPUs: ") . $cpu_string);
}

# How much memory does this lgrp contain?
sub lgrp_showmemory
{
	my $lgrp = shift;
	my $hier = shift;

	my $memory = $l->mem_size($lgrp, LGRP_MEM_SZ_INSTALLED, $hier);
	return (0) unless $memory;
	my $freemem = $l->mem_size($lgrp, LGRP_MEM_SZ_FREE, $hier);
	# Convert memory to units.
	my $memory_r = round($memory / $units);
	my $freemem_r = round($freemem / $units);
	my $usedmem = $memory_r - $freemem_r;
	my $memstr = sprintf(gettext("Memory: installed %s %s"),
			     $memory_r, $unit_str);
	$memstr = $memstr . sprintf(gettext(", allocated %s %s"),
				    $usedmem, $unit_str);
	$memstr = $memstr . sprintf(gettext(", free %s %s"),
				    $freemem_r, $unit_str);
	return ($memstr);
}

# Get string containing lgroup resources
sub lgrp_showresources
{
	my $lgrp = shift;
	my $rsrc_prefix = gettext("Lgroup resources:");
	# What resources does this lgroup contains?
	my @resources_cpu = nsort($l->resources($lgrp, LGRP_RSRC_CPU));
	my @resources_mem = nsort($l->resources($lgrp, LGRP_RSRC_MEM));
	my $rsrc = @resources_cpu || @resources_mem ? "" : gettext("none");
	$rsrc = $rsrc_prefix . $rsrc;
	my $rsrc_cpu = lgrp_collapse(@resources_cpu);
	my $rsrc_mem = lgrp_collapse(@resources_mem);
	my $lcpu = gettext("CPU");
	my $lmemory = gettext("memory");
	$rsrc = "$rsrc $rsrc_cpu ($lcpu);" if scalar @resources_cpu;
	$rsrc = "$rsrc $rsrc_mem ($lmemory)" if scalar @resources_mem;
	return ($rsrc);
}

# Consolidate consequtive ids as start-end
sub lgrp_collapse
{
	return "" unless @_;
	my @args = uniqsort(@_);
	my $start = shift(@args);
	my $end = $start;
	my $result = "";
	foreach my $el (@args) {
		if ($el == ($end + 1)) {
			$end = $el;
		} else {
			if ($end > $start + 1) {
				$result = "$result $start-$end";
			} elsif ($end > $start) {
				$result = "$result $start $end";
			} else {
				$result = "$result $start";
			}
			$start = $end = $el;
		}
	}
	if ($end > $start + 1) {
		$result = "$result $start-$end";
	} elsif ($end > $start) {
		$result = "$result $start $end";
	} else {
		$result = "$result $start";
	}
	$result =~ s/^\s+//;
	return ($result);
}

# Print latency information if requested and the system has several lgroups.
sub print_latency_table
{
	my ($lgrps1, $lgrps2) = @_;

	return unless scalar @lgrps;

	# Find maximum lgroup
	my $max = $root;
	map { $max = $_ if $max < $_ } @$lgrps1;

	# Field width for lgroup - the width of the largest lgroup and 1 space
	my $lgwidth = length($max) + 1;
	# Field width for latency. Get the maximum latency and add 1 space.
	my $width = length($l->latency($root, $root)) + 1;
	# Make sure that width is enough to print lgroup itself.
	$width = $lgwidth if $width < $lgwidth;

	# Print table header
	print gettext("\nLgroup latencies:\n");
	# Print horizontal line
	print "\n", "-" x ($lgwidth + 1);
	map { print '-' x $width } @$lgrps1;
	print "\n", " " x $lgwidth, "|";
	map { printf("%${width}d", $_) } @$lgrps1;
	print "\n", "-" x ($lgwidth + 1);
	map { print '-' x $width } @$lgrps1;
	print "\n";

	# Print the latency table
	foreach my $l1 (@$lgrps2) {
		printf "%-${lgwidth}d|", $l1;
		foreach my $l2 (@lgrps) {
			my $latency = $l->latency($l1, $l2);
			if (!defined ($latency)) {
				printf "%${width}s", "-";
			} else {
				printf "%${width}d", $latency;
			}
		}
		print "\n";
	}

	# Print table footer
	print "-" x ($lgwidth + 1);
	map { print '-' x $width } @lgrps;
	print "\n";
}
