#
# 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
#

ident	"%Z%%M%	%I%	%E% SMI"

cmd/perl/contrib/README

This directory contains SMI-developed Perl modules.  Modules related to Solaris
should be placed under Sun::Solaris, which has been reserved for SMI development
by CPAN.  Modules involving Perl installations which do not run on Solaris,
or which refer to unbundled products, should seek ARC guidance for naming.
#
# 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 (c) 2000 by Sun Microsystems, Inc.
All rights reserved.

ident	"%Z%%M%	%I%	%E% SMI"

cmd/perl/contrib/SUNW/README

This directory contains proprietary SMI-developed Perl modules.
#
# 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 (c) 2000 by Sun Microsystems, Inc.
All rights reserved.

ident	"%Z%%M%	%I%	%E% SMI"

cmd/perl/contrib/SUNW/README

This directory contains SMI-developed Perl modules that can be released as Open
Source.
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = _BSMparse

include $(SRC)/cmd/perl/Makefile.perl

PERLMOD = $(MODULE).pm

# Install module into arch independent directory
ROOTPERLMODDIR = $(ROOTPERLDIR)/lib/Sun/Solaris/BSM

.KEEP_STATE:

all:

install: $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#
# Copyright 2009 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 (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
#

# WARNING -- this package implements a Sun private interface; it may
# change without notice.

package Sun::Solaris::BSM::_BSMparse;
require 5.005;
use strict;
use Exporter;
use Sun::Solaris::Utils qw(gettext);

use vars qw($VERSION $failedOpen
    %EXPORT_TAGS @ISA @EXPORT_OK @EXPORT_FAIL);

$VERSION = '1.01';

@ISA = qw(Exporter);
my @constants = qw();
@EXPORT_OK = qw(readAttr readEvent readClass filterLabel filterCallName
		readControl getPathList readUser ckAttrEvent);
@EXPORT_FAIL = qw($failedOpen);
%EXPORT_TAGS = (ALL => \@EXPORT_OK);

$failedOpen = gettext("failed to open %s: %s");

sub new {
	my $obj = shift;
	my $debug = shift;	# bool
	my $filters = shift;	# options for filtering

	my $dir = '/etc/security';
	my $attrDir = '/usr/lib/audit';
        my $configDir = $dir;
	$attrDir = shift if (@_);	# override for test
	$configDir = shift if (@_);	# ditto

	my $suffix = '';
	$suffix = shift if (@_);	# test, again

	$obj = ref($obj) || $obj;

	my ($recordf, $classf, $controlf, $eventf, $userf) =
	   ("$attrDir/audit_record_attr$suffix",
	    "$configDir/audit_class$suffix",
	    "$configDir/audit_control$suffix",
	    "$configDir/audit_event$suffix",
	    "$configDir/audit_user$suffix");

	return (bless {
		'attrFile'	=> $recordf,
		'classFile'	=> $classf,
		'classFilter'	=> $filters->{'classFilter'},
		'controlFile'	=> $controlf,
		'debug'		=> $debug,
		'eventFile'	=> $eventf,
		'eventFilter'	=> $filters->{'eventFilter'},
		'idFilter'	=> $filters->{'idFilter'},
		'havePath'	=> 0,
		'kernelDefault'	=> '',
		'userDefault'	=> '',
		'userFile'	=> $userf}, $obj);
}

# readAttr
# read the hand edited attrFile file
#
# return a hash reference

sub readAttr {
	my $obj = shift;

	my $file = $obj->{'attrFile'};
	my $fileHandle = do {local *FileHandle; *FileHandle};
	open($fileHandle, $file) or die sprintf("$failedOpen\n", $file, $!);

	my $count = 0;
	my $lastAttr = '';
	my $lastMacro = '';

	my $attrState = -1;
	my $caseState = 0;
	my $label;
	my $callName = '';
	my $skip = '';
	my $description = 'none';
	my $format = 'none';
	my $comment = '';
	my $title = 'none';
	my $note = '';
	my $case = '';
	my @case = ();
	my %skipClass;
	my %attr = ();
	my %token = ();
	my $classFilter = $obj->{'classFilter'};
	$classFilter = '' unless (defined ($classFilter));

	my %noteAlias = ();
	while (<$fileHandle>) {
		chomp;
		s/#.*//;	 # remove comment
		next if (/^\s*$/);

		if ($attrState < 0) {  # initial state:  header info
			# continue assigning lines to multiline macros 
			# type: message
			if ( $lastMacro ne '' ) {
				my ($mcr, $attr) = split(/\s*:\s*/, $lastMacro);

				if ($mcr eq "message") {
					chomp($noteAlias{$attr}); 
					chop($noteAlias{$attr});

					$_ =~ /^\s*(.*)/i;
					$noteAlias{$attr} .= $1;

					$lastMacro = chkBslash($lastMacro, \$1);
				}
				next;
			}

			$lastMacro = '';
			if (/^\s*skipClass\s*=\s*(.*)/i) {
				my $class = $1;
				# don't skip what you're searching for
				next if (index(lc($classFilter),lc($class)) > -1);
				$skipClass{$1} = 1;
				next;
			}
			elsif (/^\s*token\s*=\s*(.*)/i) {
				my ($attr, $value) = split(/\s*:\s*/, $1);
				$token{$attr} = $value;
				next;
			}
			elsif (/^\s*message\s*=\s*(.*)/i) {
				my ($attr, $value) = split(/\s*:\s*/, $1);
				$noteAlias{$attr} = $value;
				$lastMacro = chkBslash("message:$attr", \$1);
				next;
			}
			elsif (/^\s*kernel\s*=\s*(.*)/i) {
				my ($attr, $value) = split(/\s*:\s*/, $1);
				$obj->{'kernelDefault'} = $1;
				next;
			}
			elsif (/^\s*user\s*=\s*(.*)/i) {
				my ($attr, $value) = split(/\s*:\s*/, $1);
				$obj->{'userDefault'} = $1;
				next;
			}
		}

		# continue assigning lines to multiline attributes 
		# type: case, comment, note, format
		if ( $lastAttr ne '' ) {
			my $curAttrVal = '';

			eval "\$curAttrVal = \$$lastAttr";
			chomp($curAttrVal); 
			chop($curAttrVal);

			$_ =~ /^\s*(.*)/i;
			$curAttrVal .= $1;

			eval "\$$lastAttr = \$curAttrVal";

			$lastAttr = chkBslash($lastAttr, \$1);
			next;
		}

		$lastAttr = '';
		if (/^\s*label\s*=\s*(.*)/i) {
			$attrState = 0 if ($attrState < 0);
			my $newLabel = $1;

			if ($obj->{'debug'}) {
				print STDERR qq{
$newLabel is duplicated in the attribute file (line $.)
				} if ($attr{$newLabel});
			}
			# if $attrState not zero, an unwritten record exists
			if ($attrState) {
				$callName = $obj->filterCallName($label,
				    $callName);
				push(@case, [$case, $format, $comment, $note]);

				if ($obj->filterLabel($label)) {
					$attr{$label} =
					    [$callName, $description, $title,
					    $skip, @case];
					$count++;
				}
				$format = $description = $title = 'none';
				$case = $note = $comment = $skip = $callName
				    = '';
				@case = ();
				$caseState = 0;
			}
			$label = $newLabel;
			$attrState = 1;
		}
		elsif (/^\s*skip\s*=\s*(.*)/i) {
			$skip = $1;
		}
		elsif (/^\s*syscall\s*=\s*(.*)/i) {
			$callName = $1;
		}
		elsif (/^\s*program\s*=\s*(.*)/i) {
			$callName = $1;
		}
		elsif (/^\s*title\s*=\s*(.*)/i) {
			$title = $1;
		}
		elsif (/^\s*see\s*=\s*(.*)/i) {
			$description = $1;
		}
		elsif (/^\s*format\s*=\s*(.*)/i) {
			$format = $1;
			$lastAttr = chkBslash("format", \$1);
		}
		elsif (/^\s*comment\s*=\s*(.*)/i) {
			$comment .= $1;
			$lastAttr = chkBslash("comment", \$1);
		}
		elsif (/^\s*note\s*=\s*(.*)/i) {
			$note .= $1;
			$lastAttr = chkBslash("note", \$1);
		}
		elsif (/^\s*case\s*=\s*(.*)/i) {
			if ($caseState) {
				push(@case, [$case, $format, $comment, $note]);
				$format = 'none';
				$comment = $note = '';
			}
			$case = $1;
			$lastAttr = chkBslash("case", \$1);
			$caseState = 1;
		}
	}
	if ($attrState) {
		$callName = $obj->filterCallName($label, $callName);
		push(@case, [$case, $format, $comment, $note]);
		if ($obj->filterLabel($label)) {
			$attr{$label} = [$callName, $description, $title, $skip,
			    @case];
			$count++;
		}
	}
	close $fileHandle;
	print STDERR "found $count audit attribute entries\n" if ($obj->{'debug'});

	return ($obj->{'attr'} = \%attr, \%token, \%skipClass, \%noteAlias);
}

# readEvent
# read eventFile and extract audit event information, including
# which classes are associated with each event and what call is
# related.

sub readEvent {
	my $obj = shift;

	my %event = ();
	my $file = $obj->{'eventFile'};

	my $fileHandle = do {local *FileHandle; *FileHandle};
	open($fileHandle, $file) or die sprintf("$failedOpen\n", $file, $!);

	my $count = 0;

	unless (defined $obj->{'class'} && (scalar keys %{$obj->{'class'}} > 1)) {
		$obj->readClass();
	}

	my @classFilterMasks = ();
	my $classFilter = $obj->{'classFilter'};
	if ($classFilter) {
		foreach (split(',', $classFilter)) {
			push @classFilterMasks, $obj->{'class'}{$_};
		}
	}
	# ignore customer-supplied audit events (id > 32767)

	while (<$fileHandle>) {
		chomp;
		s/#.*//;	# remove comment
		next if (/^\s*$/);
		if (/^\s*(\d+):(\w+):([^:]+):(.*)/) {
			my $id = $1;
			my $label = $2;
			my $description = $3;
			my $class = $4;

			if ($id !~ /\d+/) {
				print STDERR "$id is not numeric (line $.)\n";
				next;
			}
			next if ($id > 32767);

			$class =~ s/\s*$//;

			if ($obj->{'debug'}) {
				print STDERR qq{
$label is duplicated in the event file (line $.)
				} if ($event{$label});
			}
			next unless ($obj->filterLabel($label));
			my $mask = 0;
			if ($classFilter) {
				foreach (split(/\s*,\s*/, $class)) {
					$mask |= $obj->{'class'}{$_};
				}
				my $skip = 0;
				foreach my $filterMask (@classFilterMasks) {
					unless ($mask & $filterMask) {
						$skip = 1;
						last;
					}
				}
				next if $skip;
			}
			if ($obj->{'idFilter'}) {
				next unless ($obj->{'idFilter'} == $id);
			}
			$event{$label} = [$id, $class, $description];

			$count++;
		}
	}
	close $fileHandle;
	print STDERR "found $count audit events\n" if ($obj->{'debug'});

	return ($obj->{'event'} = \%event);
}

# readClass
# read classFile and extract audit class information

sub readClass {
	my $obj = shift;

	my %class = ();
	my $file = $obj->{'classFile'};

	my $fileHandle = do {local *FileHandle; *FileHandle};
	open($fileHandle, $file) or die sprintf("$failedOpen\n", $file, $!);

	my $count = 0;

	while (<$fileHandle>) {
		chomp;
		s/#.*//;	# remove comment
		next if (/^\s*$/);
		my ($mask1, $class) = split(/:/);  # third field not used
		my $mask2 = hex($mask1);  # integer
		$class{$class} = $mask2;
		$count++;
	}
	close $fileHandle;
	print STDERR "found $count audit classes\n" if ($obj->{'debug'});

	return ($obj->{'class'} = \%class);
}

sub filterLabel {
	my $obj = shift;
	my $label = shift;

	my $eventFilter = $obj->{'eventFilter'};
	my $keepIt = 1;

	$keepIt = 0 if ($eventFilter && ($label !~ /$eventFilter/i));

	return ($keepIt);
}

# Normally, the root of the event label is the system call.  The
# attrFile attribute syscall or program overrides this.

sub filterCallName {
	my $obj = shift;
	my $label = shift;
	my $callName = shift;

	return ($callName) if ($callName);

	$label =~ /AUE_(.*)/;

	my $name = $1;

	return (lc ($name));
}

# readControl
# read controlFile and extract flags and naflags information
# at present, minfree, maxfree and the audit partitions are not
# checked.

sub readControl {
	my $obj = shift;
	my $failMode = shift;

	my $cError = 0;
	my $errors = '';
	my $file = $obj->{'controlFile'};
	my $invalidClass = gettext('invalid class, %s, in audit_control: %s');

	my $fileHandle = do {local *FileHandle; *FileHandle};
	unless (open($fileHandle, $file)) {
		die sprintf("$failedOpen\n", $file, $!)
			unless ($failMode eq 'ignore');
		return (0, '');
	}
	my %class = $obj->{'class'};
	my @paths = $obj->{'paths'};
	while (<$fileHandle>) {
		chomp;
		s/#.*//;	# remove comment
		next if (/^\s*$/);
		if ((/^\s*flags:/i) || (/^\s*naflags:/i)) {
			my ($class) = /flags:\s*(.*)/;
			my @class = split(/\s*,\s*/, $class);

			foreach $class (@class) {
				$class =~ s/^[-+^]+//;
				unless (defined ($class{$class})) {
					$errors .=
					    sprintf("$invalidClass\n",
					    $class, $_);
					$cError++;
				}
			}
		}
		elsif (/^\s*dir:\s*(.*)/) {
			push (@paths, $1);
			$obj->{'havePath'} = 1;
		}
	}
	close $fileHandle;
	return ($cError, $errors);
}

sub getPathList {
	my $obj = shift;

	$obj->readControl() unless ($obj->{'havePath'});

	return ($obj->{'paths'});
}

# readUser
# read userFile and extract audit information for validation

sub readUser {
	my $obj = shift;
	my $failMode = shift;

	my $cError = 0;
	my $error = '';
	my $file = $obj->{'userFile'};

	my $fileHandle = do {local *FileHandle; *FileHandle};
	unless (open($fileHandle, $file)) {
		die sprintf("$failedOpen\n", $file, $!)
			unless ($failMode eq 'ignore');
		return (0, '');
	}
	# these strings are defined here mostly to avoid indentation problems
	my $emptyErr   = gettext('empty audit mask in audit_user: %s');
	my $syntaxErr1 = gettext(
	    'incorrect syntax (exactly two colons req\'d) in audit_user: %s');
	my $syntaxErr2 = gettext('incorrect syntax in audit_user: %s');
	my $invalidErr = gettext('invalid class, %s, in audit_user: %s');
	my $undefined  = gettext('undefined user name in audit_user: %s');

	my %class = $obj->{'class'};
	while (<$fileHandle>) {
		chomp;
		s/#.*//;        # remove comment
		next if (/^\s*$/);
		my $colonCount = tr/:/:/;

		if ($colonCount != 2) {
			$error .= sprintf("$syntaxErr1\n", $_);
			$cError++;
		}
		my ($user, $always, $never) = split(/\s*:\s*/);
		unless (defined($user)) {
			$error .= sprintf("$syntaxErr2\n", $_);
			$cError++;
			next;
		}
		$error .= sprintf("$emptyErr\n", $_) unless ($always);

		my ($name) = getpwnam($user);
		unless (defined($name)) {
			$error .= sprintf("$undefined\n", $user);
			$cError++;
		}
		unless (defined($always) && defined($never)) {
			$error .= sprintf("$emptyErr\n", $_);
			$cError++;
			next;
		}
		my $verify = $always . ',' . $never;
		my @class = split(/\s*,\s*/, $verify);
		my $thisClass;

		foreach $thisClass (@class) {
			$thisClass =~ s/^[-+^]+//;
			unless (defined $class{$thisClass}) {
				$error .= sprintf("$invalidErr\n", $thisClass,
				    $_);
				$cError++;
			}
		}
	}
	close $fileHandle;
	return ($cError, $error);
}

# ckAttrEvent complains if controlFile and attrFile don''t contain the
# same list of events.

sub ckAttrEvent {
	my $obj = shift;

	my $cError = 0;
	my $error = '';
	my $cAttr = 0;
	my $label;
	my $attrErr  = gettext(
	    '%s entry in attribute file but not in event file');
	my $eventErr = gettext(
	    '%s entry in event file but not in attribute file');

	my %attr = %{$obj->{'attr'}};
	my %event = %{$obj->{'event'}};
	foreach $label (keys %attr) {
		$cAttr++;
		unless ($event{$label}) {
			$error .= sprintf("$attrErr\n", $label);
			$cError++;
		}
	}
	my $cEvent = 0;
	foreach $label (keys %event) {
		$cEvent++;
		unless ($attr{$label}) {
			$error .= sprintf("$eventErr\n", $label);
			$cError++;
		}
	}
	# debug only; not I18N'd
	print STDERR
	    "$cAttr audit_record_attr entries and $cEvent audit_event entries\n"
		if ($obj->{'debug'});
	return ($cError, $error);
}

# chkBslash (helper)
# check the given string for backslash character at the end; if found
# return the string sent as a first argument, otherwise return empty
# string.
sub chkBslash ($$) {
	my $retStr = shift;
	my $strPtr = shift;

	if ( $$strPtr !~ /\\$/ ) {
		 $retStr = '';
	}

	return $retStr;
}

1;
# 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 (c) 2005, 2010, Oracle and/or its affiliates. All rights reserved.
#
# Intrs.pm provides the bootstrap for the private Sun::Solaris::Intrs module.
#

package Sun::Solaris::Intrs;

use strict;
use warnings;
use Exporter;
use DynaLoader;
use vars qw($VERSION @ISA @EXPORT_OK);

our @ISA = qw(Exporter DynaLoader);
our @EXPORT_OK = qw(intrmove is_apic);
our $VERSION = '0.02';

bootstrap Sun::Solaris::Intrs $VERSION;
1;
/*
 * 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 (c) 2005, 2010, Oracle and/or its affiliates. All rights reserved.
 */

#include <sys/types.h>
#include <sys/stat.h>
#include <sys/pci.h>
#include <fcntl.h>
#include <unistd.h>
#include <stropts.h>
#include <stdio.h>
#include <errno.h>

/* Non-shipping header - see Makefile.PL */
#include <sys/pci_tools.h>

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

static int
open_dev(char *path)
{
	char intrpath[MAXPATHLEN];

	(void) strcpy(intrpath, "/devices");
	(void) strcat(intrpath, path);
	(void) strcat(intrpath, ":intr");
	return (open(intrpath, O_RDWR));
}

MODULE = Sun::Solaris::Intrs		PACKAGE = Sun::Solaris::Intrs
PROTOTYPES: ENABLE

int
intrmove(path, oldcpu, ino, cpu, num_ino)
	char *path
	int oldcpu 
	int ino
	int cpu
	int num_ino
    INIT:
	int fd, ret;
	pcitool_intr_set_t iset;

    CODE:
	if ((fd = open_dev(path)) == -1) {
		XSRETURN_UNDEF;
	}
	iset.old_cpu = oldcpu;
	iset.ino = ino;
	iset.cpu_id = cpu;
	iset.flags = (num_ino > 1) ? PCITOOL_INTR_FLAG_SET_GROUP : 0;
	iset.user_version = PCITOOL_VERSION;

	ret = ioctl(fd, PCITOOL_DEVICE_SET_INTR, &iset);

	if (ret == -1) {
		XSRETURN_UNDEF;
	}
	(void) close(fd);
	XSRETURN_YES;

int
is_apic(path)
	char *path

    INIT:
	int fd, ret;
	pcitool_intr_info_t iinfo;

    CODE:
	if ((fd = open_dev(path)) == -1) {
		XSRETURN_UNDEF;
	}
	iinfo.user_version = PCITOOL_VERSION;

	ret = ioctl(fd, PCITOOL_SYSTEM_INTR_INFO, &iinfo);
	(void) close(fd);

	if (ret == -1) {
		XSRETURN_UNDEF;
	}

	if (iinfo.ctlr_type == PCITOOL_CTLR_TYPE_PCPLUSMP ||
	    iinfo.ctlr_type == PCITOOL_CTLR_TYPE_APIX) {
		XSRETURN_YES;
	}

	XSRETURN_NO;
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

include $(SRC)/Makefile.master

SUBDIRS = $(MACH64)

all :		TARGET = all
install :	TARGET = install
clean :	TARGET = clean
clobber :	TARGET = clobber

all install clean clobber: $(SUBDIRS)

$(SUBDIRS): FRC
	@cd $@; pwd; $(MAKE) $(TARGET)

FRC:
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = Intrs

include $(SRC)/cmd/perl/Makefile.perl

CERRWARN += -Wno-unused-variable

MAPFILES = ../mapfile-vers
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#

# Copyright 2022, Richard Lowe.

include ../Makefile.com
include $(SRC)/cmd/perl/Makefile.perl.64

all: $(PERLEXT)
install: $(ROOTPERLEXT) $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright (c) 2014 Racktop Systems.
#

$mapfile_version 2

SYMBOL_SCOPE {
    global:
	boot_Sun__Solaris__Intrs;
	XS_Sun__Solaris__Intrs_is_apic;
	XS_Sun__Solaris__Intrs_intrmove;
    local:
        *;
};
#
# 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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#

#
# Kstat.pm provides the bootstrap for the Sun::Solaris::Kstat module.
#

package Sun::Solaris::Kstat;
use strict;
use DynaLoader;
use vars qw($VERSION @ISA);
$VERSION = '1.3';
@ISA = qw(DynaLoader);
bootstrap Sun::Solaris::Kstat $VERSION;
1;
/*
 * 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 (c) 1999, 2010, Oracle and/or its affiliates. All rights reserved.
 * Copyright (c) 2014 Racktop Systems.
 * Copyright 2019 OmniOS Community Edition (OmniOSce) Association.
 * Copyright 2020 Peter Tribble.
 */

/*
 * Kstat.xs is a Perl XS (eXStension module) that makes the Solaris
 * kstat(3KSTAT) facility available to Perl scripts.  Kstat is a general-purpose
 * mechanism  for  providing kernel statistics to users.  The Solaris API is
 * function-based (see the manpage for details), but for ease of use in Perl
 * scripts this module presents the information as a nested hash data structure.
 * It would be too inefficient to read every kstat in the system, so this module
 * uses the Perl TIEHASH mechanism to implement a read-on-demand semantic, which
 * only reads and updates kstats as and when they are actually accessed.
 */

/*
 * Ignored raw kstats.
 *
 * Some raw kstats are ignored by this module, these are listed below.  The
 * most common reason is that the kstats are stored as arrays and the ks_ndata
 * and/or ks_data_size fields are invalid.  In this case it is impossible to
 * know how many records are in the array, so they can't be read.
 *
 * unix:*:sfmmu_percpu_stat
 * This is stored as an array with one entry per cpu.  Each element is of type
 * struct sfmmu_percpu_stat.  The ks_ndata and ks_data_size fields are bogus.
 *
 * ufs directio:*:UFS DirectIO Stats
 * The structure definition used for these kstats (ufs_directio_kstats) is in a
 * C file (uts/common/fs/ufs/ufs_directio.c) rather than a header file, so it
 * isn't accessible.
 *
 * qlc:*:statistics
 * This is a third-party driver for which we don't have source.
 *
 * mm:*:phys_installed
 * This is stored as an array of uint64_t, with each pair of values being the
 * (address, size) of a memory segment.  The ks_ndata and ks_data_size fields
 * are both zero.
 *
 * sockfs:*:sock_unix_list
 * This is stored as an array with one entry per active socket.  Each element
 * is of type struct sockinfo.  ks_ndata is the number of elements of that
 * array and ks_data_size is the total size of the array.
 *
 * Note that the ks_ndata and ks_data_size of many non-array raw kstats are
 * also incorrect.  The relevant assertions are therefore commented out in the
 * appropriate raw kstat read routines.
 */

/* Kstat related includes */
#include <libgen.h>
#include <kstat.h>
#include <sys/var.h>
#include <sys/utsname.h>
#include <sys/sysinfo.h>
#include <sys/flock.h>
#include <sys/dnlc.h>
#include <nfs/nfs.h>
#include <nfs/nfs_clnt.h>

/* Ultra-specific kstat includes */
#ifdef __sparc
#include <vm/hat_sfmmu.h>	/* from /usr/platform/sun4u/include */
#endif

/*
 * Solaris #defines SP, which conflicts with the perl definition of SP
 * We don't need the Solaris one, so get rid of it to avoid warnings
 */
#undef SP

/* Perl XS includes */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* Debug macros */
#define	DEBUG_ID "Sun::Solaris::Kstat"
#ifdef KSTAT_DEBUG
#define	PERL_ASSERT(EXP) \
    ((void)((EXP) || (croak("%s: assertion failed at %s:%d: %s", \
    DEBUG_ID, __FILE__, __LINE__, #EXP), 0), 0))
#define	PERL_ASSERTMSG(EXP, MSG) \
    ((void)((EXP) || (croak(DEBUG_ID ": " MSG), 0), 0))
#else
#define	PERL_ASSERT(EXP)		((void)0)
#define	PERL_ASSERTMSG(EXP, MSG)	((void)0)
#endif

/* Macros for saving the contents of KSTAT_RAW structures */
#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
#define NEW_IV(V) \
    (newSViv((IVTYPE) V))
#define NEW_UV(V) \
    (newSVuv((UVTYPE) V))
#else
#define NEW_IV(V) \
    (V >= IV_MIN && V <= IV_MAX ? newSViv((IVTYPE) V) : newSVnv((NVTYPE) V))
#if defined(UVTYPE)
#define NEW_UV(V) \
    (V <= UV_MAX ? newSVuv((UVTYPE) V) : newSVnv((NVTYPE) V))
# else
#define NEW_UV(V) \
    (V <= IV_MAX ? newSViv((IVTYPE) V) : newSVnv((NVTYPE) V))
#endif
#endif
#define	NEW_HRTIME(V) \
    newSVnv((NVTYPE) (V / 1000000000.0))

#define	SAVE_FNP(H, F, K) \
    hv_store(H, K, sizeof (K) - 1, newSViv((IVTYPE)(uintptr_t)&F), 0)
#define	SAVE_STRING(H, S, K, SS) \
    hv_store(H, #K, sizeof (#K) - 1, \
    newSVpvn(S->K, SS ? strlen(S->K) : sizeof(S->K)), 0)
#define	SAVE_INT32(H, S, K) \
    hv_store(H, #K, sizeof (#K) - 1, NEW_IV(S->K), 0)
#define	SAVE_UINT32(H, S, K) \
    hv_store(H, #K, sizeof (#K) - 1, NEW_UV(S->K), 0)
#define	SAVE_INT64(H, S, K) \
    hv_store(H, #K, sizeof (#K) - 1, NEW_IV(S->K), 0)
#define	SAVE_UINT64(H, S, K) \
    hv_store(H, #K, sizeof (#K) - 1, NEW_UV(S->K), 0)
#define	SAVE_HRTIME(H, S, K) \
    hv_store(H, #K, sizeof (#K) - 1, NEW_HRTIME(S->K), 0)

/* Private structure used for saving kstat info in the tied hashes */
typedef struct {
	char		read;		/* Kstat block has been read before */
	char		valid;		/* Kstat still exists in kstat chain */
	char		strip_str;	/* Strip KSTAT_DATA_CHAR fields */
	kstat_ctl_t	*kstat_ctl;	/* Handle returned by kstat_open */
	kstat_t		*kstat;		/* Handle used by kstat_read */
} KstatInfo_t;

/* typedef for apply_to_ties callback functions */
typedef int (*ATTCb_t)(HV *, void *);

/* typedef for raw kstat reader functions */
typedef void (*kstat_raw_reader_t)(HV *, kstat_t *, int);

/* Hash of "module:name" to KSTAT_RAW read functions */
static HV *raw_kstat_lookup;

/*
 * Kstats come in two flavours, named and raw.  Raw kstats are just C structs,
 * so we need a function per raw kstat to convert the C struct into the
 * corresponding perl hash.  All such conversion functions are in the following
 * section.
 */

/*
 * Definitions in /usr/include/sys/cpuvar.h and /usr/include/sys/sysinfo.h
 */

static void
save_cpu_stat(HV *self, kstat_t *kp, int strip_str)
{
	cpu_stat_t    *statp;
	cpu_sysinfo_t *sysinfop;
	cpu_syswait_t *syswaitp;
	cpu_vminfo_t  *vminfop;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (cpu_stat_t));
	statp = (cpu_stat_t *)(kp->ks_data);
	sysinfop = &statp->cpu_sysinfo;
	syswaitp = &statp->cpu_syswait;
	vminfop  = &statp->cpu_vminfo;

	hv_store(self, "idle", 4, NEW_UV(sysinfop->cpu[CPU_IDLE]), 0);
	hv_store(self, "user", 4, NEW_UV(sysinfop->cpu[CPU_USER]), 0);
	hv_store(self, "kernel", 6, NEW_UV(sysinfop->cpu[CPU_KERNEL]), 0);
	hv_store(self, "wait", 4, NEW_UV(sysinfop->cpu[CPU_WAIT]), 0);
	hv_store(self, "wait_io", 7, NEW_UV(sysinfop->wait[W_IO]), 0);
	hv_store(self, "wait_swap", 9, NEW_UV(sysinfop->wait[W_SWAP]), 0);
	hv_store(self, "wait_pio",  8, NEW_UV(sysinfop->wait[W_PIO]), 0);
	SAVE_UINT32(self, sysinfop, bread);
	SAVE_UINT32(self, sysinfop, bwrite);
	SAVE_UINT32(self, sysinfop, lread);
	SAVE_UINT32(self, sysinfop, lwrite);
	SAVE_UINT32(self, sysinfop, phread);
	SAVE_UINT32(self, sysinfop, phwrite);
	SAVE_UINT32(self, sysinfop, pswitch);
	SAVE_UINT32(self, sysinfop, trap);
	SAVE_UINT32(self, sysinfop, intr);
	SAVE_UINT32(self, sysinfop, syscall);
	SAVE_UINT32(self, sysinfop, sysread);
	SAVE_UINT32(self, sysinfop, syswrite);
	SAVE_UINT32(self, sysinfop, sysfork);
	SAVE_UINT32(self, sysinfop, sysvfork);
	SAVE_UINT32(self, sysinfop, sysexec);
	SAVE_UINT32(self, sysinfop, readch);
	SAVE_UINT32(self, sysinfop, writech);
	SAVE_UINT32(self, sysinfop, rcvint);
	SAVE_UINT32(self, sysinfop, xmtint);
	SAVE_UINT32(self, sysinfop, mdmint);
	SAVE_UINT32(self, sysinfop, rawch);
	SAVE_UINT32(self, sysinfop, canch);
	SAVE_UINT32(self, sysinfop, outch);
	SAVE_UINT32(self, sysinfop, msg);
	SAVE_UINT32(self, sysinfop, sema);
	SAVE_UINT32(self, sysinfop, namei);
	SAVE_UINT32(self, sysinfop, ufsiget);
	SAVE_UINT32(self, sysinfop, ufsdirblk);
	SAVE_UINT32(self, sysinfop, ufsipage);
	SAVE_UINT32(self, sysinfop, ufsinopage);
	SAVE_UINT32(self, sysinfop, inodeovf);
	SAVE_UINT32(self, sysinfop, fileovf);
	SAVE_UINT32(self, sysinfop, procovf);
	SAVE_UINT32(self, sysinfop, intrthread);
	SAVE_UINT32(self, sysinfop, intrblk);
	SAVE_UINT32(self, sysinfop, idlethread);
	SAVE_UINT32(self, sysinfop, inv_swtch);
	SAVE_UINT32(self, sysinfop, nthreads);
	SAVE_UINT32(self, sysinfop, cpumigrate);
	SAVE_UINT32(self, sysinfop, xcalls);
	SAVE_UINT32(self, sysinfop, mutex_adenters);
	SAVE_UINT32(self, sysinfop, rw_rdfails);
	SAVE_UINT32(self, sysinfop, rw_wrfails);
	SAVE_UINT32(self, sysinfop, modload);
	SAVE_UINT32(self, sysinfop, modunload);
	SAVE_UINT32(self, sysinfop, bawrite);
#ifdef STATISTICS	/* see header file */
	SAVE_UINT32(self, sysinfop, rw_enters);
	SAVE_UINT32(self, sysinfop, win_uo_cnt);
	SAVE_UINT32(self, sysinfop, win_uu_cnt);
	SAVE_UINT32(self, sysinfop, win_so_cnt);
	SAVE_UINT32(self, sysinfop, win_su_cnt);
	SAVE_UINT32(self, sysinfop, win_suo_cnt);
#endif

	SAVE_INT32(self, syswaitp, iowait);
	SAVE_INT32(self, syswaitp, swap);
	SAVE_INT32(self, syswaitp, physio);

	SAVE_UINT32(self, vminfop, pgrec);
	SAVE_UINT32(self, vminfop, pgfrec);
	SAVE_UINT32(self, vminfop, pgin);
	SAVE_UINT32(self, vminfop, pgpgin);
	SAVE_UINT32(self, vminfop, pgout);
	SAVE_UINT32(self, vminfop, pgpgout);
	SAVE_UINT32(self, vminfop, swapin);
	SAVE_UINT32(self, vminfop, pgswapin);
	SAVE_UINT32(self, vminfop, swapout);
	SAVE_UINT32(self, vminfop, pgswapout);
	SAVE_UINT32(self, vminfop, zfod);
	SAVE_UINT32(self, vminfop, dfree);
	SAVE_UINT32(self, vminfop, scan);
	SAVE_UINT32(self, vminfop, rev);
	SAVE_UINT32(self, vminfop, hat_fault);
	SAVE_UINT32(self, vminfop, as_fault);
	SAVE_UINT32(self, vminfop, maj_fault);
	SAVE_UINT32(self, vminfop, cow_fault);
	SAVE_UINT32(self, vminfop, prot_fault);
	SAVE_UINT32(self, vminfop, softlock);
	SAVE_UINT32(self, vminfop, kernel_asflt);
	SAVE_UINT32(self, vminfop, pgrrun);
	SAVE_UINT32(self, vminfop, execpgin);
	SAVE_UINT32(self, vminfop, execpgout);
	SAVE_UINT32(self, vminfop, execfree);
	SAVE_UINT32(self, vminfop, anonpgin);
	SAVE_UINT32(self, vminfop, anonpgout);
	SAVE_UINT32(self, vminfop, anonfree);
	SAVE_UINT32(self, vminfop, fspgin);
	SAVE_UINT32(self, vminfop, fspgout);
	SAVE_UINT32(self, vminfop, fsfree);
}

/*
 * Definitions in /usr/include/sys/var.h
 */

static void
save_var(HV *self, kstat_t *kp, int strip_str)
{
	struct var *varp;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (struct var));
	varp = (struct var *)(kp->ks_data);

	SAVE_INT32(self, varp, v_buf);
	SAVE_INT32(self, varp, v_call);
	SAVE_INT32(self, varp, v_proc);
	SAVE_INT32(self, varp, v_maxupttl);
	SAVE_INT32(self, varp, v_nglobpris);
	SAVE_INT32(self, varp, v_maxsyspri);
	SAVE_INT32(self, varp, v_clist);
	SAVE_INT32(self, varp, v_maxup);
	SAVE_INT32(self, varp, v_hbuf);
	SAVE_INT32(self, varp, v_hmask);
	SAVE_INT32(self, varp, v_pbuf);
	SAVE_INT32(self, varp, v_sptmap);
	SAVE_INT32(self, varp, v_maxpmem);
	SAVE_INT32(self, varp, v_autoup);
	SAVE_INT32(self, varp, v_bufhwm);
}

/*
 * Definition in /usr/include/sys/dnlc.h
 */

static void
save_ncstats(HV *self, kstat_t *kp, int strip_str)
{
	struct ncstats *ncstatsp;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (struct ncstats));
	ncstatsp = (struct ncstats *)(kp->ks_data);

	SAVE_INT32(self, ncstatsp, hits);
	SAVE_INT32(self, ncstatsp, misses);
	SAVE_INT32(self, ncstatsp, enters);
	SAVE_INT32(self, ncstatsp, dbl_enters);
	SAVE_INT32(self, ncstatsp, long_enter);
	SAVE_INT32(self, ncstatsp, long_look);
	SAVE_INT32(self, ncstatsp, move_to_front);
	SAVE_INT32(self, ncstatsp, purges);
}

/*
 * Definition in  /usr/include/sys/sysinfo.h
 */

static void
save_sysinfo(HV *self, kstat_t *kp, int strip_str)
{
	sysinfo_t *sysinfop;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (sysinfo_t));
	sysinfop = (sysinfo_t *)(kp->ks_data);

	SAVE_UINT32(self, sysinfop, updates);
	SAVE_UINT32(self, sysinfop, runque);
	SAVE_UINT32(self, sysinfop, runocc);
	SAVE_UINT32(self, sysinfop, swpque);
	SAVE_UINT32(self, sysinfop, swpocc);
	SAVE_UINT32(self, sysinfop, waiting);
}

/*
 * Definition in  /usr/include/sys/sysinfo.h
 */

static void
save_vminfo(HV *self, kstat_t *kp, int strip_str)
{
	vminfo_t *vminfop;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (vminfo_t));
	vminfop = (vminfo_t *)(kp->ks_data);

	SAVE_UINT64(self, vminfop, freemem);
	SAVE_UINT64(self, vminfop, swap_resv);
	SAVE_UINT64(self, vminfop, swap_alloc);
	SAVE_UINT64(self, vminfop, swap_avail);
	SAVE_UINT64(self, vminfop, swap_free);
	SAVE_UINT64(self, vminfop, updates);
}

/*
 * Definition in /usr/include/nfs/nfs_clnt.h
 */

static void
save_nfs(HV *self, kstat_t *kp, int strip_str)
{
	struct mntinfo_kstat *mntinfop;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (struct mntinfo_kstat));
	mntinfop = (struct mntinfo_kstat *)(kp->ks_data);

	SAVE_STRING(self, mntinfop, mik_proto, strip_str);
	SAVE_UINT32(self, mntinfop, mik_vers);
	SAVE_UINT32(self, mntinfop, mik_flags);
	SAVE_UINT32(self, mntinfop, mik_secmod);
	SAVE_UINT32(self, mntinfop, mik_curread);
	SAVE_UINT32(self, mntinfop, mik_curwrite);
	SAVE_INT32(self, mntinfop, mik_timeo);
	SAVE_INT32(self, mntinfop, mik_retrans);
	SAVE_UINT32(self, mntinfop, mik_acregmin);
	SAVE_UINT32(self, mntinfop, mik_acregmax);
	SAVE_UINT32(self, mntinfop, mik_acdirmin);
	SAVE_UINT32(self, mntinfop, mik_acdirmax);
	hv_store(self, "lookup_srtt", 11,
	    NEW_UV(mntinfop->mik_timers[0].srtt), 0);
	hv_store(self, "lookup_deviate", 14,
	    NEW_UV(mntinfop->mik_timers[0].deviate), 0);
	hv_store(self, "lookup_rtxcur", 13,
	    NEW_UV(mntinfop->mik_timers[0].rtxcur), 0);
	hv_store(self, "read_srtt", 9,
	    NEW_UV(mntinfop->mik_timers[1].srtt), 0);
	hv_store(self, "read_deviate", 12,
	    NEW_UV(mntinfop->mik_timers[1].deviate), 0);
	hv_store(self, "read_rtxcur", 11,
	    NEW_UV(mntinfop->mik_timers[1].rtxcur), 0);
	hv_store(self, "write_srtt", 10,
	    NEW_UV(mntinfop->mik_timers[2].srtt), 0);
	hv_store(self, "write_deviate", 13,
	    NEW_UV(mntinfop->mik_timers[2].deviate), 0);
	hv_store(self, "write_rtxcur", 12,
	    NEW_UV(mntinfop->mik_timers[2].rtxcur), 0);
	SAVE_UINT32(self, mntinfop, mik_noresponse);
	SAVE_UINT32(self, mntinfop, mik_failover);
	SAVE_UINT32(self, mntinfop, mik_remap);
	SAVE_STRING(self, mntinfop, mik_curserver, strip_str);
}

/*
 * The following struct => hash functions are all only present on the sparc
 * platform, so they are all conditionally compiled depending on __sparc
 */

/*
 * Definition in /usr/platform/sun4u/include/vm/hat_sfmmu.h
 */

#ifdef __sparc
static void
save_sfmmu_global_stat(HV *self, kstat_t *kp, int strip_str)
{
	struct sfmmu_global_stat *sfmmugp;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (struct sfmmu_global_stat));
	sfmmugp = (struct sfmmu_global_stat *)(kp->ks_data);

	SAVE_INT32(self, sfmmugp, sf_tsb_exceptions);
	SAVE_INT32(self, sfmmugp, sf_tsb_raise_exception);
	SAVE_INT32(self, sfmmugp, sf_pagefaults);
	SAVE_INT32(self, sfmmugp, sf_uhash_searches);
	SAVE_INT32(self, sfmmugp, sf_uhash_links);
	SAVE_INT32(self, sfmmugp, sf_khash_searches);
	SAVE_INT32(self, sfmmugp, sf_khash_links);
	SAVE_INT32(self, sfmmugp, sf_swapout);
	SAVE_INT32(self, sfmmugp, sf_tsb_alloc);
	SAVE_INT32(self, sfmmugp, sf_tsb_allocfail);
	SAVE_INT32(self, sfmmugp, sf_tsb_sectsb_create);
	SAVE_INT32(self, sfmmugp, sf_scd_1sttsb_alloc);
	SAVE_INT32(self, sfmmugp, sf_scd_2ndtsb_alloc);
	SAVE_INT32(self, sfmmugp, sf_scd_1sttsb_allocfail);
	SAVE_INT32(self, sfmmugp, sf_scd_2ndtsb_allocfail);
	SAVE_INT32(self, sfmmugp, sf_tteload8k);
	SAVE_INT32(self, sfmmugp, sf_tteload64k);
	SAVE_INT32(self, sfmmugp, sf_tteload512k);
	SAVE_INT32(self, sfmmugp, sf_tteload4m);
	SAVE_INT32(self, sfmmugp, sf_tteload32m);
	SAVE_INT32(self, sfmmugp, sf_tteload256m);
	SAVE_INT32(self, sfmmugp, sf_tsb_load8k);
	SAVE_INT32(self, sfmmugp, sf_tsb_load4m);
	SAVE_INT32(self, sfmmugp, sf_hblk_hit);
	SAVE_INT32(self, sfmmugp, sf_hblk8_ncreate);
	SAVE_INT32(self, sfmmugp, sf_hblk8_nalloc);
	SAVE_INT32(self, sfmmugp, sf_hblk1_ncreate);
	SAVE_INT32(self, sfmmugp, sf_hblk1_nalloc);
	SAVE_INT32(self, sfmmugp, sf_hblk_slab_cnt);
	SAVE_INT32(self, sfmmugp, sf_hblk_reserve_cnt);
	SAVE_INT32(self, sfmmugp, sf_hblk_recurse_cnt);
	SAVE_INT32(self, sfmmugp, sf_hblk_reserve_hit);
	SAVE_INT32(self, sfmmugp, sf_get_free_success);
	SAVE_INT32(self, sfmmugp, sf_get_free_throttle);
	SAVE_INT32(self, sfmmugp, sf_get_free_fail);
	SAVE_INT32(self, sfmmugp, sf_put_free_success);
	SAVE_INT32(self, sfmmugp, sf_put_free_fail);
	SAVE_INT32(self, sfmmugp, sf_pgcolor_conflict);
	SAVE_INT32(self, sfmmugp, sf_uncache_conflict);
	SAVE_INT32(self, sfmmugp, sf_unload_conflict);
	SAVE_INT32(self, sfmmugp, sf_ism_uncache);
	SAVE_INT32(self, sfmmugp, sf_ism_recache);
	SAVE_INT32(self, sfmmugp, sf_recache);
	SAVE_INT32(self, sfmmugp, sf_steal_count);
	SAVE_INT32(self, sfmmugp, sf_pagesync);
	SAVE_INT32(self, sfmmugp, sf_clrwrt);
	SAVE_INT32(self, sfmmugp, sf_pagesync_invalid);
	SAVE_INT32(self, sfmmugp, sf_kernel_xcalls);
	SAVE_INT32(self, sfmmugp, sf_user_xcalls);
	SAVE_INT32(self, sfmmugp, sf_tsb_grow);
	SAVE_INT32(self, sfmmugp, sf_tsb_shrink);
	SAVE_INT32(self, sfmmugp, sf_tsb_resize_failures);
	SAVE_INT32(self, sfmmugp, sf_tsb_reloc);
	SAVE_INT32(self, sfmmugp, sf_user_vtop);
	SAVE_INT32(self, sfmmugp, sf_ctx_inv);
	SAVE_INT32(self, sfmmugp, sf_tlb_reprog_pgsz);
	SAVE_INT32(self, sfmmugp, sf_region_remap_demap);
	SAVE_INT32(self, sfmmugp, sf_create_scd);
	SAVE_INT32(self, sfmmugp, sf_join_scd);
	SAVE_INT32(self, sfmmugp, sf_leave_scd);
	SAVE_INT32(self, sfmmugp, sf_destroy_scd);
}
#endif

/*
 * Definition in /usr/platform/sun4u/include/vm/hat_sfmmu.h
 */

#ifdef __sparc
static void
save_sfmmu_tsbsize_stat(HV *self, kstat_t *kp, int strip_str)
{
	struct sfmmu_tsbsize_stat *sfmmutp;

	/* PERL_ASSERT(kp->ks_ndata == 1); */
	PERL_ASSERT(kp->ks_data_size == sizeof (struct sfmmu_tsbsize_stat));
	sfmmutp = (struct sfmmu_tsbsize_stat *)(kp->ks_data);

	SAVE_INT32(self, sfmmutp, sf_tsbsz_8k);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_16k);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_32k);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_64k);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_128k);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_256k);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_512k);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_1m);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_2m);
	SAVE_INT32(self, sfmmutp, sf_tsbsz_4m);
}
#endif

/*
 * We need to be able to find the function corresponding to a particular raw
 * kstat.  To do this we ignore the instance and glue the module and name
 * together to form a composite key.  We can then use the data in the kstat
 * structure to find the appropriate function.  We use a perl hash to manage the
 * lookup, where the key is "module:name" and the value is a pointer to the
 * appropriate C function.
 *
 * Note that some kstats include the instance number as part of the module
 * and/or name.  This could be construed as a bug.  However, to work around this
 * we omit any digits from the module and name as we build the table in
 * build_raw_kstat_lookup(), and we remove any digits from the module and name
 * when we look up the functions in lookup_raw_kstat_fn()
 */

/*
 * This function is called when the XS is first dlopen()ed, and builds the
 * lookup table as described above.
 */

static void
build_raw_kstat_lookup()
	{
	/* Create new hash */
	raw_kstat_lookup = newHV();

	SAVE_FNP(raw_kstat_lookup, save_cpu_stat, "cpu_stat:cpu_stat");
	SAVE_FNP(raw_kstat_lookup, save_var, "unix:var");
	SAVE_FNP(raw_kstat_lookup, save_ncstats, "unix:ncstats");
	SAVE_FNP(raw_kstat_lookup, save_sysinfo, "unix:sysinfo");
	SAVE_FNP(raw_kstat_lookup, save_vminfo, "unix:vminfo");
	SAVE_FNP(raw_kstat_lookup, save_nfs, "nfs:mntinfo");
#ifdef __sparc
	SAVE_FNP(raw_kstat_lookup, save_sfmmu_global_stat,
	    "unix:sfmmu_global_stat");
	SAVE_FNP(raw_kstat_lookup, save_sfmmu_tsbsize_stat,
	    "unix:sfmmu_tsbsize_stat");
#endif
}

/*
 * This finds and returns the raw kstat reader function corresponding to the
 * supplied module and name.  If no matching function exists, 0 is returned.
 */

static kstat_raw_reader_t lookup_raw_kstat_fn(char *module, char *name)
	{
	char			key[KSTAT_STRLEN * 2];
	register char		*f, *t;
	SV			**entry;
	kstat_raw_reader_t	fnp;

	/* Copy across module & name, removing any digits - see comment above */
	for (f = module, t = key; *f != '\0'; f++, t++) {
		while (*f != '\0' && isdigit(*f)) { f++; }
		*t = *f;
	}
	*t++ = ':';
	for (f = name; *f != '\0'; f++, t++) {
		while (*f != '\0' && isdigit(*f)) {
			f++;
		}
	*t = *f;
	}
	*t = '\0';

	/* look up & return the function, or teturn 0 if not found */
	if ((entry = hv_fetch(raw_kstat_lookup, key, strlen(key), FALSE)) == 0)
	{
		fnp = 0;
	} else {
		fnp = (kstat_raw_reader_t)(uintptr_t)SvIV(*entry);
	}
	return (fnp);
}

/*
 * This module converts the flat list returned by kstat_read() into a perl hash
 * tree keyed on module, instance, name and statistic.  The following functions
 * provide code to create the nested hashes, and to iterate over them.
 */

/*
 * Given module, instance and name keys return a pointer to the hash tied to
 * the bottommost hash.  If the hash already exists, we just return a pointer
 * to it, otherwise we create the hash and any others also required above it in
 * the hierarchy.  The returned tiehash is blessed into the
 * Sun::Solaris::Kstat::_Stat class, so that the appropriate TIEHASH methods are
 * called when the bottommost hash is accessed.  If the is_new parameter is
 * non-null it will be set to TRUE if a new tie has been created, and FALSE if
 * the tie already existed.
 */

static HV *
get_tie(SV *self, char *module, int instance, char *name, int *is_new)
{
	char str_inst[11];	/* big enough for up to 10^10 instances */
	char *key[3];		/* 3 part key: module, instance, name */
	int  k;
	int  new;
	HV   *hash;
	HV   *tie;

	/* Create the keys */
	(void) snprintf(str_inst, sizeof (str_inst), "%d", instance);
	key[0] = module;
	key[1] = str_inst;
	key[2] = name;

	/* Iteratively descend the tree, creating new hashes as required */
	hash = (HV *)SvRV(self);
	for (k = 0; k < 3; k++) {
		SV **entry;

		SvREADONLY_off(hash);
		entry = hv_fetch(hash, key[k], strlen(key[k]), TRUE);

		/* If the entry doesn't exist, create it */
		if (! SvOK(*entry)) {
			HV *newhash;
			SV *rv;

			newhash = newHV();
			rv = newRV_noinc((SV *)newhash);
			sv_setsv(*entry, rv);
			SvREFCNT_dec(rv);
			if (k < 2) {
				SvREADONLY_on(newhash);
			}
			SvREADONLY_on(*entry);
			SvREADONLY_on(hash);
			hash = newhash;
			new = 1;

		/* Otherwise it already existed */
		} else {
			SvREADONLY_on(hash);
			hash = (HV *)SvRV(*entry);
			new = 0;
		}
	}

	/* Create and bless a hash for the tie, if necessary */
	if (new) {
		SV *tieref;
		HV *stash;

		tie = newHV();
		tieref = newRV_noinc((SV *)tie);
		stash = gv_stashpv("Sun::Solaris::Kstat::_Stat", TRUE);
		sv_bless(tieref, stash);

		/* Add TIEHASH magic */
		hv_magic(hash, (GV *)tieref, 'P');
		SvREFCNT_dec(tieref);
		SvREADONLY_on(hash);

	/* Otherwise, just find the existing tied hash */
	} else {
		MAGIC *mg;

		mg = mg_find((SV *)hash, 'P');
		PERL_ASSERTMSG(mg != 0, "get_tie: lost P magic");
		tie = (HV *)SvRV(mg->mg_obj);
	}
	if (is_new) {
		*is_new = new;
	}
	return (tie);
}

/*
 * This is an iterator function used to traverse the hash hierarchy and apply
 * the passed function to the tied hashes at the bottom of the hierarchy.  If
 * any of the callback functions return 0, 0 is returned, otherwise 1
 */

static int
apply_to_ties(SV *self, ATTCb_t cb, void *arg)
{
	HV	*hash1;
	HE	*entry1;
	int	ret;

	hash1 = (HV *)SvRV(self);
	hv_iterinit(hash1);
	ret = 1;

	/* Iterate over each module */
	while ((entry1 = hv_iternext(hash1))) {
		HV *hash2;
		HE *entry2;

		hash2 = (HV *)SvRV(hv_iterval(hash1, entry1));
		hv_iterinit(hash2);

		/* Iterate over each module:instance */
		while ((entry2 = hv_iternext(hash2))) {
			HV *hash3;
			HE *entry3;

			hash3 = (HV *)SvRV(hv_iterval(hash2, entry2));
			hv_iterinit(hash3);

			/* Iterate over each module:instance:name */
			while ((entry3 = hv_iternext(hash3))) {
				HV    *hash4;
				MAGIC *mg;

				/* Get the tie */
				hash4 = (HV *)SvRV(hv_iterval(hash3, entry3));
				mg = mg_find((SV *)hash4, 'P');
				PERL_ASSERTMSG(mg != 0,
				    "apply_to_ties: lost P magic");

				/* Apply the callback */
				if (! cb((HV *)SvRV(mg->mg_obj), arg)) {
					ret = 0;
				}
			}
		}
	}
	return (ret);
}

/*
 * Mark this HV as valid - used by update() when pruning deleted kstat nodes
 */

static int
set_valid(HV *self, void *arg)
{
	MAGIC *mg;

	mg = mg_find((SV *)self, '~');
	PERL_ASSERTMSG(mg != 0, "set_valid: lost ~ magic");
	((KstatInfo_t *)SvPVX(mg->mg_obj))->valid = (int)(intptr_t)arg;
	return (1);
}

/*
 * Prune invalid kstat nodes. This is called when kstat_chain_update() detects
 * that the kstat chain has been updated.  This removes any hash tree entries
 * that no longer have a corresponding kstat.  If del is non-null it will be
 * set to the keys of the deleted kstat nodes, if any.  If any entries are
 * deleted 1 will be retured, otherwise 0
 */

static int
prune_invalid(SV *self, AV *del)
{
	HV	*hash1;
	HE	*entry1;
	STRLEN	klen;
	char	*module, *instance, *name, *key;
	int	ret;

	hash1 = (HV *)SvRV(self);
	hv_iterinit(hash1);
	ret = 0;

	/* Iterate over each module */
	while ((entry1 = hv_iternext(hash1))) {
		HV *hash2;
		HE *entry2;

		module = HePV(entry1, PL_na);
		hash2 = (HV *)SvRV(hv_iterval(hash1, entry1));
		hv_iterinit(hash2);

		/* Iterate over each module:instance */
		while ((entry2 = hv_iternext(hash2))) {
			HV *hash3;
			HE *entry3;

			instance = HePV(entry2, PL_na);
			hash3 = (HV *)SvRV(hv_iterval(hash2, entry2));
			hv_iterinit(hash3);

			/* Iterate over each module:instance:name */
			while ((entry3 = hv_iternext(hash3))) {
				HV    *hash4;
				MAGIC *mg;
				HV    *tie;

				name = HePV(entry3, PL_na);
				hash4 = (HV *)SvRV(hv_iterval(hash3, entry3));
				mg = mg_find((SV *)hash4, 'P');
				PERL_ASSERTMSG(mg != 0,
				    "prune_invalid: lost P magic");
				tie = (HV *)SvRV(mg->mg_obj);
				mg = mg_find((SV *)tie, '~');
				PERL_ASSERTMSG(mg != 0,
				    "prune_invalid: lost ~ magic");

				/* If this is marked as invalid, prune it */
				if (((KstatInfo_t *)SvPVX(
				    (SV *)mg->mg_obj))->valid == FALSE) {
					SvREADONLY_off(hash3);
					key = HePV(entry3, klen);
					hv_delete(hash3, key, klen, G_DISCARD);
					SvREADONLY_on(hash3);
					if (del) {
						av_push(del,
						    newSVpvf("%s:%s:%s",
						    module, instance, name));
					}
					ret = 1;
				}
			}

			/* If the module:instance:name hash is empty prune it */
			if (HvKEYS(hash3) == 0) {
				SvREADONLY_off(hash2);
				key = HePV(entry2, klen);
				hv_delete(hash2, key, klen, G_DISCARD);
				SvREADONLY_on(hash2);
			}
		}
		/* If the module:instance hash is empty prune it */
		if (HvKEYS(hash2) == 0) {
			SvREADONLY_off(hash1);
			key = HePV(entry1, klen);
			hv_delete(hash1, key, klen, G_DISCARD);
			SvREADONLY_on(hash1);
		}
	}
	return (ret);
}

/*
 * Named kstats are returned as a list of key/values.  This function converts
 * such a list into the equivalent perl datatypes, and stores them in the passed
 * hash.
 */

static void
save_named(HV *self, kstat_t *kp, int strip_str)
{
	kstat_named_t	*knp;
	int		n;
	SV*		value;

	for (n = kp->ks_ndata, knp = KSTAT_NAMED_PTR(kp); n > 0; n--, knp++) {
		switch (knp->data_type) {
		case KSTAT_DATA_CHAR:
			value = newSVpv(knp->value.c, strip_str ?
			    strlen(knp->value.c) : sizeof (knp->value.c));
			break;
		case KSTAT_DATA_INT32:
			value = newSViv(knp->value.i32);
			break;
		case KSTAT_DATA_UINT32:
			value = NEW_UV(knp->value.ui32);
			break;
		case KSTAT_DATA_INT64:
			value = NEW_UV(knp->value.i64);
			break;
		case KSTAT_DATA_UINT64:
			value = NEW_UV(knp->value.ui64);
			break;
		case KSTAT_DATA_STRING:
			if (KSTAT_NAMED_STR_PTR(knp) == NULL)
				value = newSVpv("null", sizeof ("null") - 1);
			else
				value = newSVpv(KSTAT_NAMED_STR_PTR(knp),
						KSTAT_NAMED_STR_BUFLEN(knp) -1);
			break;
		default:
			PERL_ASSERTMSG(0, "kstat_read: invalid data type");
			continue;
		}
		hv_store(self, knp->name, strlen(knp->name), value, 0);
	}
}

/*
 * Save kstat interrupt statistics
 */

static void
save_intr(HV *self, kstat_t *kp, int strip_str)
{
	kstat_intr_t	*kintrp;
	int		i;
	static char	*intr_names[] =
	    { "hard", "soft", "watchdog", "spurious", "multiple_service" };

	PERL_ASSERT(kp->ks_ndata == 1);
	PERL_ASSERT(kp->ks_data_size == sizeof (kstat_intr_t));
	kintrp = KSTAT_INTR_PTR(kp);

	for (i = 0; i < KSTAT_NUM_INTRS; i++) {
		hv_store(self, intr_names[i], strlen(intr_names[i]),
		    NEW_UV(kintrp->intrs[i]), 0);
	}
}

/*
 * Save IO statistics
 */

static void
save_io(HV *self, kstat_t *kp, int strip_str)
{
	kstat_io_t *kiop;

	PERL_ASSERT(kp->ks_ndata == 1);
	PERL_ASSERT(kp->ks_data_size == sizeof (kstat_io_t));
	kiop = KSTAT_IO_PTR(kp);
	SAVE_UINT64(self, kiop, nread);
	SAVE_UINT64(self, kiop, nwritten);
	SAVE_UINT32(self, kiop, reads);
	SAVE_UINT32(self, kiop, writes);
	SAVE_HRTIME(self, kiop, wtime);
	SAVE_HRTIME(self, kiop, wlentime);
	SAVE_HRTIME(self, kiop, wlastupdate);
	SAVE_HRTIME(self, kiop, rtime);
	SAVE_HRTIME(self, kiop, rlentime);
	SAVE_HRTIME(self, kiop, rlastupdate);
	SAVE_UINT32(self, kiop, wcnt);
	SAVE_UINT32(self, kiop, rcnt);
}

/*
 * Save timer statistics
 */

static void
save_timer(HV *self, kstat_t *kp, int strip_str)
{
	kstat_timer_t *ktimerp;

	PERL_ASSERT(kp->ks_ndata == 1);
	PERL_ASSERT(kp->ks_data_size == sizeof (kstat_timer_t));
	ktimerp = KSTAT_TIMER_PTR(kp);
	SAVE_STRING(self, ktimerp, name, strip_str);
	SAVE_UINT64(self, ktimerp, num_events);
	SAVE_HRTIME(self, ktimerp, elapsed_time);
	SAVE_HRTIME(self, ktimerp, min_time);
	SAVE_HRTIME(self, ktimerp, max_time);
	SAVE_HRTIME(self, ktimerp, start_time);
	SAVE_HRTIME(self, ktimerp, stop_time);
}

/*
 * Read kstats and copy into the supplied perl hash structure.  If refresh is
 * true, this function is being called as part of the update() method.  In this
 * case it is only necessary to read the kstats if they have previously been
 * accessed (kip->read == TRUE).  If refresh is false, this function is being
 * called prior to returning a value to the caller. In this case, it is only
 * necessary to read the kstats if they have not previously been read.  If the
 * kstat_read() fails, 0 is returned, otherwise 1
 */

static int
read_kstats(HV *self, int refresh)
{
	MAGIC			*mg;
	KstatInfo_t		*kip;
	kstat_raw_reader_t	fnp;

	/* Find the MAGIC KstatInfo_t data structure */
	mg = mg_find((SV *)self, '~');
	PERL_ASSERTMSG(mg != 0, "read_kstats: lost ~ magic");
	kip = (KstatInfo_t *)SvPVX(mg->mg_obj);

	/* Return early if we don't need to actually read the kstats */
	if ((refresh && ! kip->read) || (! refresh && kip->read)) {
		return (1);
	}

	/* Read the kstats and return 0 if this fails */
	if (kstat_read(kip->kstat_ctl, kip->kstat, NULL) < 0) {
		return (0);
	}

	/* Save the read data */
	hv_store(self, "snaptime", 8, NEW_HRTIME(kip->kstat->ks_snaptime), 0);
	switch (kip->kstat->ks_type) {
		case KSTAT_TYPE_RAW:
			if ((fnp = lookup_raw_kstat_fn(kip->kstat->ks_module,
			    kip->kstat->ks_name)) != 0) {
				fnp(self, kip->kstat, kip->strip_str);
			}
			break;
		case KSTAT_TYPE_NAMED:
			save_named(self, kip->kstat, kip->strip_str);
			break;
		case KSTAT_TYPE_INTR:
			save_intr(self, kip->kstat, kip->strip_str);
			break;
		case KSTAT_TYPE_IO:
			save_io(self, kip->kstat, kip->strip_str);
			break;
		case KSTAT_TYPE_TIMER:
			save_timer(self, kip->kstat, kip->strip_str);
			break;
		default:
			PERL_ASSERTMSG(0, "read_kstats: illegal kstat type");
			break;
	}
	kip->read = TRUE;
	return (1);
}

static int
read_kstats_wrap(HV *self, void *ptr)
{
	int refresh = (intptr_t)ptr;

	return (read_kstats(self, refresh));
}

/*
 * The XS code exported to perl is below here.  Note that the XS preprocessor
 * has its own commenting syntax, so all comments from this point on are in
 * that form.
 */

/* The following XS methods are the ABI of the Sun::Solaris::Kstat package */

MODULE = Sun::Solaris::Kstat PACKAGE = Sun::Solaris::Kstat
PROTOTYPES: ENABLE

 # Create the raw kstat to store function lookup table on load
BOOT:
	build_raw_kstat_lookup();

 #
 # The Sun::Solaris::Kstat constructor.  This builds the nested
 # name::instance::module hash structure, but doesn't actually read the
 # underlying kstats.  This is done on demand by the TIEHASH methods in
 # Sun::Solaris::Kstat::_Stat
 #

SV*
new(class, ...)
	char *class;
PREINIT:
	HV		*stash;
	kstat_ctl_t	*kc;
	SV		*kcsv;
	kstat_t		*kp;
	KstatInfo_t	kstatinfo;
	int		sp, strip_str;
CODE:
	/* Check we have an even number of arguments, excluding the class */
	sp = 1;
	if (((items - sp) % 2) != 0) {
		croak(DEBUG_ID ": new: invalid number of arguments");
	}

	/* Process any (name => value) arguments */
	strip_str = 0;
	while (sp < items) {
		SV *name, *value;

		name = ST(sp);
		sp++;
		value = ST(sp);
		sp++;
		if (strcmp(SvPVX(name), "strip_strings") == 0) {
			strip_str = SvTRUE(value);
		} else {
			croak(DEBUG_ID ": new: invalid parameter name '%s'",
			    SvPVX(name));
		}
	}

	/* Open the kstats handle */
	if ((kc = kstat_open()) == 0) {
		XSRETURN_UNDEF;
	}

	/* Create a blessed hash ref */
	RETVAL = (SV *)newRV_noinc((SV *)newHV());
	stash = gv_stashpv(class, TRUE);
	sv_bless(RETVAL, stash);

	/* Create a place to save the KstatInfo_t structure */
	kcsv = newSVpv((char *)&kc, sizeof (kc));
	sv_magic(SvRV(RETVAL), kcsv, '~', 0, 0);
	SvREFCNT_dec(kcsv);

	/* Initialise the KstatsInfo_t structure */
	kstatinfo.read = FALSE;
	kstatinfo.valid = TRUE;
	kstatinfo.strip_str = strip_str;
	kstatinfo.kstat_ctl = kc;

	/* Scan the kstat chain, building hash entries for the kstats */
	for (kp = kc->kc_chain; kp != 0; kp = kp->ks_next) {
		HV *tie;
		SV *kstatsv;

		/* Don't bother storing the kstat headers */
		if (strncmp(kp->ks_name, "kstat_", 6) == 0) {
			continue;
		}

		/* Don't bother storing raw stats we don't understand */
		if (kp->ks_type == KSTAT_TYPE_RAW &&
		    lookup_raw_kstat_fn(kp->ks_module, kp->ks_name) == 0) {
#ifdef REPORT_UNKNOWN
			(void) fprintf(stderr,
			    "Unknown kstat type %s:%d:%s - %d of size %d\n",
			    kp->ks_module, kp->ks_instance, kp->ks_name,
			    kp->ks_ndata, kp->ks_data_size);
#endif
			continue;
		}

		/* Create a 3-layer hash hierarchy - module.instance.name */
		tie = get_tie(RETVAL, kp->ks_module, kp->ks_instance,
		    kp->ks_name, 0);

		/* Save the data necessary to read the kstat info on demand */
		hv_store(tie, "class", 5, newSVpv(kp->ks_class, 0), 0);
		hv_store(tie, "crtime", 6, NEW_HRTIME(kp->ks_crtime), 0);
		kstatinfo.kstat = kp;
		kstatsv = newSVpv((char *)&kstatinfo, sizeof (kstatinfo));
		sv_magic((SV *)tie, kstatsv, '~', 0, 0);
		SvREFCNT_dec(kstatsv);
	}
	SvREADONLY_on(SvRV(RETVAL));
	/* SvREADONLY_on(RETVAL); */
OUTPUT:
	RETVAL

 #
 # Update the perl hash structure so that it is in line with the kernel kstats
 # data.  Only kstats athat have previously been accessed are read,
 #

 # Scalar context: true/false
 # Array context: (\@added, \@deleted)
void
update(self)
	SV* self;
PREINIT:
	MAGIC		*mg;
	kstat_ctl_t	*kc;
	kstat_t		*kp;
	int		ret;
	AV		*add, *del;
PPCODE:
	/* Find the hidden KstatInfo_t structure */
	mg = mg_find(SvRV(self), '~');
	PERL_ASSERTMSG(mg != 0, "update: lost ~ magic");
	kc = *(kstat_ctl_t **)SvPVX(mg->mg_obj);

	/* Update the kstat chain, and return immediately on error. */
	if ((ret = kstat_chain_update(kc)) == -1) {
		if (GIMME_V == G_ARRAY) {
			EXTEND(SP, 2);
			PUSHs(sv_newmortal());
			PUSHs(sv_newmortal());
		} else {
			EXTEND(SP, 1);
			PUSHs(sv_2mortal(newSViv(ret)));
		}
	}

	/* Create the arrays to be returned if in an array context */
	if (GIMME_V == G_ARRAY) {
		add = newAV();
		del = newAV();
	} else {
		add = 0;
		del = 0;
	}

	/*
	 * If the kstat chain hasn't changed we can just reread any stats
	 * that have already been read
	 */
	if (ret == 0) {
		if (! apply_to_ties(self, read_kstats_wrap, (void *)TRUE)) {
			if (GIMME_V == G_ARRAY) {
				EXTEND(SP, 2);
				PUSHs(sv_2mortal(newRV_noinc((SV *)add)));
				PUSHs(sv_2mortal(newRV_noinc((SV *)del)));
			} else {
				EXTEND(SP, 1);
				PUSHs(sv_2mortal(newSViv(-1)));
			}
		}

	/*
	 * Otherwise we have to update the Perl structure so that it is in
	 * agreement with the new kstat chain.  We do this in such a way as to
	 * retain all the existing structures, just adding or deleting the
	 * bare minimum.
	 */
	} else {
		KstatInfo_t	kstatinfo;

		/*
		 * Step 1: set the 'invalid' flag on each entry
		 */
		apply_to_ties(self, &set_valid, (void *)FALSE);

		/*
		 * Step 2: Set the 'valid' flag on all entries still in the
		 * kernel kstat chain
		 */
		kstatinfo.read		= FALSE;
		kstatinfo.valid		= TRUE;
		kstatinfo.kstat_ctl	= kc;
		for (kp = kc->kc_chain; kp != 0; kp = kp->ks_next) {
			int	new;
			HV	*tie;

			/* Don't bother storing the kstat headers or types */
			if (strncmp(kp->ks_name, "kstat_", 6) == 0) {
				continue;
			}

			/* Don't bother storing raw stats we don't understand */
			if (kp->ks_type == KSTAT_TYPE_RAW &&
			    lookup_raw_kstat_fn(kp->ks_module, kp->ks_name)
			    == 0) {
#ifdef REPORT_UNKNOWN
				(void) printf("Unknown kstat type %s:%d:%s "
				    "- %d of size %d\n", kp->ks_module,
				    kp->ks_instance, kp->ks_name,
				    kp->ks_ndata, kp->ks_data_size);
#endif
				continue;
			}

			/* Find the tied hash associated with the kstat entry */
			tie = get_tie(self, kp->ks_module, kp->ks_instance,
			    kp->ks_name, &new);

			/* If newly created store the associated kstat info */
			if (new) {
				SV *kstatsv;

				/*
				 * Save the data necessary to read the kstat
				 * info on demand
				 */
				hv_store(tie, "class", 5,
				    newSVpv(kp->ks_class, 0), 0);
				hv_store(tie, "crtime", 6,
				    NEW_HRTIME(kp->ks_crtime), 0);
				kstatinfo.kstat = kp;
				kstatsv = newSVpv((char *)&kstatinfo,
				    sizeof (kstatinfo));
				sv_magic((SV *)tie, kstatsv, '~', 0, 0);
				SvREFCNT_dec(kstatsv);

				/* Save the key on the add list, if required */
				if (GIMME_V == G_ARRAY) {
					av_push(add, newSVpvf("%s:%d:%s",
					    kp->ks_module, kp->ks_instance,
					    kp->ks_name));
				}

			/* If the stats already exist, just update them */
			} else {
				MAGIC *mg;
				KstatInfo_t *kip;

				/* Find the hidden KstatInfo_t */
				mg = mg_find((SV *)tie, '~');
				PERL_ASSERTMSG(mg != 0, "update: lost ~ magic");
				kip = (KstatInfo_t *)SvPVX(mg->mg_obj);

				/* Mark the tie as valid */
				kip->valid = TRUE;

				/* Re-save the kstat_t pointer.  If the kstat
				 * has been deleted and re-added since the last
				 * update, the address of the kstat structure
				 * will have changed, even though the kstat will
				 * still live at the same place in the perl
				 * hash tree structure.
				 */
				kip->kstat = kp;

				/* Reread the stats, if read previously */
				read_kstats(tie, TRUE);
			}
		}

		/*
		 *Step 3: Delete any entries still marked as 'invalid'
		 */
		ret = prune_invalid(self, del);

	}
	if (GIMME_V == G_ARRAY) {
		EXTEND(SP, 2);
		PUSHs(sv_2mortal(newRV_noinc((SV *)add)));
		PUSHs(sv_2mortal(newRV_noinc((SV *)del)));
	} else {
		EXTEND(SP, 1);
		PUSHs(sv_2mortal(newSViv(ret)));
	}


 #
 # Destructor.  Closes the kstat connection
 #

void
DESTROY(self)
	SV *self;
PREINIT:
	MAGIC		*mg;
	kstat_ctl_t	*kc;
CODE:
	mg = mg_find(SvRV(self), '~');
	PERL_ASSERTMSG(mg != 0, "DESTROY: lost ~ magic");
	kc = *(kstat_ctl_t **)SvPVX(mg->mg_obj);
	if (kstat_close(kc) != 0) {
		croak(DEBUG_ID ": kstat_close: failed");
	}

 #
 # The following XS methods implement the TIEHASH mechanism used to update the
 # kstats hash structure.  These are blessed into a package that isn't
 # visible to callers of the Sun::Solaris::Kstat module
 #

MODULE = Sun::Solaris::Kstat PACKAGE = Sun::Solaris::Kstat::_Stat
PROTOTYPES: ENABLE

 #
 # If a value has already been read, return it.  Otherwise read the appropriate
 # kstat and then return the value
 #

SV*
FETCH(self, key)
	SV* self;
	SV* key;
PREINIT:
	char	*k;
	STRLEN	klen;
	SV	**value;
CODE:
	self = SvRV(self);
	k = SvPV(key, klen);
	if (strNE(k, "class") && strNE(k, "crtime")) {
		read_kstats((HV *)self, FALSE);
	}
	value = hv_fetch((HV *)self, k, klen, FALSE);
	if (value) {
		RETVAL = *value; SvREFCNT_inc(RETVAL);
	} else {
		RETVAL = &PL_sv_undef;
	}
OUTPUT:
	RETVAL

 #
 # Save the passed value into the kstat hash.  Read the appropriate kstat first,
 # if necessary.  Note that this DOES NOT update the underlying kernel kstat
 # structure.
 #

SV*
STORE(self, key, value)
	SV* self;
	SV* key;
	SV* value;
PREINIT:
	char	*k;
	STRLEN	klen;
CODE:
	self = SvRV(self);
	k = SvPV(key, klen);
	if (strNE(k, "class") && strNE(k, "crtime")) {
		read_kstats((HV *)self, FALSE);
	}
	SvREFCNT_inc(value);
	RETVAL = *(hv_store((HV *)self, k, klen, value, 0));
	SvREFCNT_inc(RETVAL);
OUTPUT:
	RETVAL

 #
 # Check for the existence of the passed key.  Read the kstat first if necessary
 #

bool
EXISTS(self, key)
	SV* self;
	SV* key;
PREINIT:
	char *k;
CODE:
	self = SvRV(self);
	k = SvPV(key, PL_na);
	if (strNE(k, "class") && strNE(k, "crtime")) {
		read_kstats((HV *)self, FALSE);
	}
	RETVAL = hv_exists_ent((HV *)self, key, 0);
OUTPUT:
	RETVAL


 #
 # Hash iterator initialisation.  Read the kstats if necessary.
 #

SV*
FIRSTKEY(self)
	SV* self;
PREINIT:
	HE *he;
PPCODE:
	self = SvRV(self);
	read_kstats((HV *)self, FALSE);
	hv_iterinit((HV *)self);
	if ((he = hv_iternext((HV *)self))) {
		EXTEND(SP, 1);
		PUSHs(hv_iterkeysv(he));
	}

 #
 # Return hash iterator next value.  Read the kstats if necessary.
 #

SV*
NEXTKEY(self, lastkey)
	SV* self;
	SV* lastkey;
PREINIT:
	HE *he;
PPCODE:
	self = SvRV(self);
	if ((he = hv_iternext((HV *)self))) {
		EXTEND(SP, 1);
		PUSHs(hv_iterkeysv(he));
	}


 #
 # Delete the specified hash entry.
 #

SV*
DELETE(self, key)
	SV *self;
	SV *key;
CODE:
	self = SvRV(self);
	RETVAL = hv_delete_ent((HV *)self, key, 0, 0);
	if (RETVAL) {
		SvREFCNT_inc(RETVAL);
	} else {
		RETVAL = &PL_sv_undef;
	}
OUTPUT:
	RETVAL

 #
 # Clear the entire hash.  This will stop any update() calls rereading this
 # kstat until it is accessed again.
 #

void
CLEAR(self)
	SV* self;
PREINIT:
	MAGIC   *mg;
	KstatInfo_t *kip;
CODE:
	self = SvRV(self);
	hv_clear((HV *)self);
	mg = mg_find(self, '~');
	PERL_ASSERTMSG(mg != 0, "CLEAR: lost ~ magic");
	kip = (KstatInfo_t *)SvPVX(mg->mg_obj);
	kip->read  = FALSE;
	kip->valid = TRUE;
	hv_store((HV *)self, "class", 5, newSVpv(kip->kstat->ks_class, 0), 0);
	hv_store((HV *)self, "crtime", 6, NEW_HRTIME(kip->kstat->ks_crtime), 0);
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

include $(SRC)/Makefile.master

SUBDIRS = $(MACH64)

all :		TARGET = all
install :	TARGET = install
clean :	TARGET = clean
clobber :	TARGET = clobber

all install clean clobber: $(SUBDIRS)

$(SUBDIRS): FRC
	@cd $@; pwd; $(MAKE) $(TARGET)

FRC:
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
# Copyright 2014 Gary Mills
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = Kstat

include $(SRC)/cmd/perl/Makefile.perl

LDLIBS += -lkstat

CERRWARN += -Wno-unused-value
CERRWARN += -Wno-unused-variable

# Hammerhead: SPARC include paths removed - amd64 only

MAPFILES = ../mapfile-vers
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#

# Copyright 2022, Richard Lowe.

include ../Makefile.com
include $(SRC)/cmd/perl/Makefile.perl.64

all: $(PERLEXT)
install: $(ROOTPERLEXT) $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright (c) 2014 Racktop Systems.
#

$mapfile_version 2

SYMBOL_SCOPE {
    global:
	boot_Sun__Solaris__Kstat;
	XS_Sun__Solaris__Kstat___Stat_CLEAR;
	XS_Sun__Solaris__Kstat___Stat_DELETE;
	XS_Sun__Solaris__Kstat___Stat_EXISTS;
	XS_Sun__Solaris__Kstat___Stat_FETCH;
	XS_Sun__Solaris__Kstat___Stat_FIRSTKEY;
	XS_Sun__Solaris__Kstat___Stat_NEXTKEY;
	XS_Sun__Solaris__Kstat___Stat_STORE;
	XS_Sun__Solaris__Kstat_DESTROY;
	XS_Sun__Solaris__Kstat_new;
	XS_Sun__Solaris__Kstat_update;
    local:
	*;
};
#
# 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
#
#ident	"%Z%%M%	%I%	%E% SMI"
#
# test script for Sun::Solaris::Kstat
#

use strict;

# Visit all the leaf nodes -
# will generate a die if there are any structure mismatches
sub visit_all($)
{
	my ($ks) = @_;
	foreach my $m (sort(keys(%$ks))) {
		foreach my $i (sort(keys(%{$ks->{$m}}))) {
			foreach my $n (sort(keys(%{$ks->{$m}->{$i}}))) {
				foreach my $k (sort(
				    keys(%{$ks->{$m}->{$i}->{$n}}))) {
					my $v = $ks->{$m}->{$i}->{$n}->{$k};
				}
			}
		}
	}
	return(1);
}

BEGIN { $| = 1; print "1..15\n"; }
my $loaded;
END {print "not ok 1\n" unless $loaded;}
use Sun::Solaris::Kstat;
$loaded = 1;
print "ok 1\n";

# Check we can create a Kstat object OK
my ($test, $ks);
$test = 2;
if (! eval { $ks = Sun::Solaris::Kstat->new() }) {
	print("not ok $test: $@");
} else {
	print("ok $test\n");
}
$test++;

# Check FIRSTKEY/NEXTKEY/FETCH and for structure mismatches
if (! eval { visit_all($ks) }) {
	print("not ok $test: $@");
} else {
	print("ok $test\n");
}
$test++;

# Find a cpu number
my $cpu = (keys(%{$ks->{cpu_info}}))[0];
my $cpu_info = "cpu_info$cpu";

# Check EXISTS
if (exists($ks->{cpu_info}{$cpu}{$cpu_info}{state})) {
	print("ok $test\n");
} else {
	print("not ok $test\n");
}
$test++;

# Check DELETE
my $val = delete($ks->{cpu_info}{$cpu}{$cpu_info}{state});
if (defined($val) && ($val =~ /^on-line/ || $val =~ /^off-line/)) {
	print("ok $test\n");
} else {
	print("not ok $test ($val)\n");
}
$test++;

# 5.004_04 has a broken hv_delete
if ($] < 5.00405) {
	print("ok $test\n");
	$test++;
	print("ok $test\n");
	$test++;
} else {
	if (! exists($ks->{cpu_info}{$cpu}{$cpu_info}{state})) {
		print("ok $test\n");
	} else {
		print("not ok $test\n");
	}
	$test++;
	$val = $ks->{cpu_info}{$cpu}{$cpu_info}{state};
	if (! defined($val)) {
		print("ok $test\n");
	} else {
		print("not ok $test\n");
	}
	$test++;
}

# Check STORE
$ks->{cpu_info}{$cpu}{$cpu_info}{state} = "california";
if ($ks->{cpu_info}{$cpu}{$cpu_info}{state} eq "california") {
	print("ok $test\n");
} else {
	print("not ok $test\n");
}
$test++;

# Check CLEAR
my @bvals = sort(keys(%{$ks->{cpu_info}{$cpu}{$cpu_info}}));
%{$ks->{cpu_info}{$cpu}{$cpu_info}} = ();
my @avals = sort(keys(%{$ks->{cpu_info}{$cpu}{$cpu_info}}));
while (@bvals || @avals) {
	my $a = shift(@avals);
	my $b = shift(@bvals);
	if ($a ne $b) { print("not ok $test ($a ne $b)\n"); last; }
}
print("ok $test\n") if (! @avals && ! @bvals);
$test++;

# Check updates
if (! defined(eval { $ks->update() })) {
	print("not ok $test: $@");
} else {
	print("ok $test\n");
}
$test++;

# Check readonly-ness of hash structure
eval { $ks->{cpu_info}{$cpu}{$cpu_info} = {}; };
print($@ =~ /^Modification of a read-only/i ? "ok $test\n" : "not ok $test\n");
$test++;

eval { $ks->{cpu_info}{$cpu} = {}; };
print($@ =~ /^Modification of a read-only/i ? "ok $test\n" : "not ok $test\n");
$test++;

eval { $ks->{cpu_info} = {}; };
print($@ =~ /^Modification of a read-only/i ? "ok $test\n" : "not ok $test\n");
$test++;

# Check timestamps
my $then = $ks->{cpu_info}{$cpu}{$cpu_info}{snaptime};
sleep(3);
if (! defined(eval { $ks->update() })) {
	print("not ok $test: $@");
} else {
	print("ok $test\n");
}
$test++;
my $interval = $ks->{cpu_info}{$cpu}{$cpu_info}{snaptime} - $then;
if ($interval >= 2.5 && $interval <= 3.5) {
	print("ok $test\n");
} else {
	print("not ok $test\n");
}
$test++;

exit(0);
#
# 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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#

Version 1.1
Initial Public Source release.
#
# 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.
# Copyright (c) 2014 Racktop Systems.
#

#
# Lgrp.pm provides procedural and object-oriented interface to the Solaris
# liblgrp(3LIB) library.
#


require 5.0010;
use strict;
use warnings;
use Carp;

package Sun::Solaris::Lgrp;

our $VERSION = '1.1';
use XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);

require Exporter;

our @ISA = qw(Exporter);

our (@EXPORT_OK, %EXPORT_TAGS);

# Things to export
my @lgrp_constants = qw(LGRP_AFF_NONE LGRP_AFF_STRONG LGRP_AFF_WEAK
			LGRP_CONTENT_DIRECT LGRP_CONTENT_HIERARCHY
			LGRP_MEM_SZ_FREE LGRP_MEM_SZ_INSTALLED LGRP_VER_CURRENT
			LGRP_VER_NONE LGRP_VIEW_CALLER
			LGRP_VIEW_OS LGRP_NONE
			LGRP_RSRC_CPU LGRP_RSRC_MEM
			LGRP_CONTENT_ALL LGRP_LAT_CPU_TO_MEM
);

my @proc_constants = qw(P_PID P_LWPID P_MYID);

my @constants = (@lgrp_constants, @proc_constants);

my @functions = qw(lgrp_affinity_get lgrp_affinity_set
		   lgrp_children lgrp_cookie_stale lgrp_cpus lgrp_fini
		   lgrp_home lgrp_init lgrp_latency lgrp_latency_cookie
		   lgrp_mem_size lgrp_nlgrps lgrp_parents
		   lgrp_root lgrp_version lgrp_view lgrp_resources
		   lgrp_isleaf lgrp_lgrps lgrp_leaves);

my @all = (@constants, @functions);

# Define symbolic names for various subsets of export lists
%EXPORT_TAGS = ('CONSTANTS' => \@constants,
		'LGRP_CONSTANTS' => \@lgrp_constants,
		'PROC_CONSTANTS' => \@proc_constants,
		'FUNCTIONS' => \@functions,
		'ALL' => \@all);

# Define things that are ok ot export.
@EXPORT_OK = ( @{ $EXPORT_TAGS{'ALL'} } );

#
# _usage(): print error message and terminate the program.
#
sub _usage
{
	my $msg = shift;
	Carp::croak "Usage: Sun::Solaris::Lgrp::$msg";
}

#
# lgrp_isleaf($cookie, $lgrp)
#   Returns T if lgrp is leaf, F otherwise.
#
sub lgrp_isleaf
{
	scalar @_ == 2 or _usage "lgrp_isleaf(cookie, lgrp)";
	return (!lgrp_children(shift, shift));
}

#
# lgrp_lgrps($cookie, [$lgrp])
#   Returns: list of lgrps in a subtree starting from $lgrp.
# 	     If $root is not specified, use lgrp_root.
# 	     undef on failure.
sub lgrp_lgrps
{
	scalar @_ > 0 or _usage("lgrp_lgrps(cookie, [lgrp])");
	my $cookie = shift;
	my $root = shift;
	$root = lgrp_root($cookie) unless defined $root;
	return unless defined $root;
	my @children = lgrp_children($cookie, $root);
	my @result;

	#
	# Concatenate root with subtrees for every children. Every subtree is
	# obtained by calling lgrp_lgrps recursively with each of the children
	# as the argument.
	#
	@result = @children ?
	  ($root, map {lgrp_lgrps($cookie, $_)} @children) :
	    ($root);
	return (wantarray ? @result : scalar @result);
}

#
# lgrp_leaves($cookie, [$lgrp])
#   Returns: list of leaves in the hierarchy starting from $lgrp.
# 	     If $lgrp is not specified, use lgrp_root.
# 	     undef on failure.
#
sub lgrp_leaves
{
	scalar @_ > 0 or _usage("lgrp_leaves(cookie, [lgrp])");
	my $cookie = shift;
	my $root = shift;
	$root = lgrp_root($cookie) unless defined $root;
	return unless defined $root;
	my @result = grep {
		lgrp_isleaf($cookie, $_)
	} lgrp_lgrps($cookie, $root);
	return (wantarray ? @result : scalar @result);
}

######################################################################
# Object-Oriented interface.
######################################################################

#
# cookie: extract cookie from the argument.
# If the argument is scalar, it is the cookie itself, otherwise it is the
# reference to the object and the cookie value is in $self->{COOKIE}.
#
sub cookie
{
	my $self = shift;
	return ((ref $self) ? $self->{COOKIE} : $self);
}

#
# new: The object constructor
#
sub new
{
	my $class = shift;
	my ($self, $view);
	$view = shift;
	$self->{COOKIE} = ($view ? lgrp_init($view) : lgrp_init()) or
	  croak("lgrp_init: $!\n"), return;
	bless($self, $class) if defined($class);
	bless($self) unless defined($class);
	return ($self);
}

#
# DESTROY: the object destructor.
#
sub DESTROY
{
	lgrp_fini(cookie(shift));
}

############################################################
# Wrapper methods.
#
sub stale
{
	scalar @_ == 1 or _usage("stale(class)");
	return (lgrp_cookie_stale(cookie(shift)));
}

sub view
{
	scalar @_ == 1 or _usage("view(class)");
	return (lgrp_view(cookie(shift)));
}

sub root
{
	scalar @_ == 1 or _usage("root(class)");
	return (lgrp_root(cookie(shift)));
}

sub nlgrps
{
	scalar @_ == 1 or _usage("nlgrps(class)");
	return (lgrp_nlgrps(cookie(shift)));
}

sub lgrps
{
	scalar @_ > 0 or _usage("lgrps(class, [lgrp])");
	return (lgrp_lgrps(cookie(shift), shift));
}

sub leaves
{
	scalar @_ > 0 or _usage("leaves(class, [lgrp])");
	return (lgrp_leaves(cookie(shift), shift));
}

sub version
{
	scalar @_ > 0 or _usage("leaves(class, [version])");
	shift;
	return (lgrp_version(shift || 0));
}

sub children
{
	scalar @_ == 2 or _usage("children(class, lgrp)");
	return (lgrp_children(cookie(shift), shift));
}

sub parents
{
	scalar @_ == 2 or _usage("parents(class, lgrp)");
	return (lgrp_parents(cookie(shift), shift));
}

sub mem_size
{
	scalar @_ == 4 or _usage("mem_size(class, lgrp, type, content)");
	return (lgrp_mem_size(cookie(shift), shift, shift, shift));
}

sub cpus
{
	scalar @_ == 3 or _usage("cpus(class, lgrp, content)");
	return (lgrp_cpus(cookie(shift), shift, shift));
}

sub isleaf
{
	scalar @_ == 2 or _usage("isleaf(class, lgrp)");
	lgrp_isleaf(cookie(shift), shift);
}

sub resources
{
	scalar @_ == 3 or _usage("resources(class, lgrp, resource)");
	return (lgrp_resources(cookie(shift), shift, shift));
}

sub latency
{
	scalar @_ == 3 or _usage("latency(class, from, to)");
	return (lgrp_latency_cookie(cookie(shift), shift, shift));
}

# Methods that do not require cookie
sub home
{
	scalar @_ == 3 or _usage("home(class, idtype, id)");
	shift;
	return (lgrp_home(shift, shift));
}

sub affinity_get
{
	scalar @_ == 4 or _usage("affinity_get(class, idtype, id, lgrp)");
	shift;
	return (lgrp_affinity_get(shift, shift, shift));
}

sub affinity_set
{
	scalar @_ == 5 or
	  _usage("affinity_set(class, idtype, id, lgrp, affinity)");
	shift;
	return (lgrp_affinity_set(shift, shift, shift, shift));
}

1;

__END__
/*
 * 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 2006 Sun Microsystems, Inc.  All rights reserved.
 * Use is subject to license terms.
 */

/*
 * Lgrp.xs contains XS wrappers for the system locality group library
 * liblgrp(3LIB).
 */

#include <sys/errno.h>
#include <sys/lgrp_user.h>

/*
 * On i386 Solaris defines SP, which conflicts with the perl definition of SP
 * We don't need the Solaris one, so get rid of it to avoid warnings.
 */
#undef SP

/* Perl XS includes. */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* Return undef in scalar context and empty list in list context */
#define LGRP_BADVAL() {			\
	if (GIMME_V == G_ARRAY)		\
			XSRETURN_EMPTY;	\
		else			\
			XSRETURN_UNDEF;	\
}

/*
 * Push all values from input array onto the perl return stack.
 */
#define	PUSHARRAY(array, nitems)	\
{					\
	int x;				\
					\
	if (nitems < 0) {		\
		LGRP_BADVAL()		\
	} else if (nitems > 0) {	\
		EXTEND(SP, nitems);	\
		for (x = 0; x < nitems; x++) {	\
			PUSHs(sv_2mortal(newSVnv(array[x])));	\
		}			\
	}				\
}

/*
 * Several constants are not present in the first version of the Lgrp API,
 * we define them here.
 *
 * lgrp_resources() and lgrp_latency_cookie() only appear in API v2. If the
 * module is linked with old version of liblgrp(3LIB) there is no lgrp_resources
 * symbol in the library and perl wrapper returns empty list and sets errno to
 * EINVAL.
 *
 * The lgrp_latency_cookie() is emulated using lgrp_latency().
 */
#if LGRP_VER_CURRENT == 1
#define	LGRP_CONTENT_ALL LGRP_CONTENT_HIERARCHY
#define	LGRP_LAT_CPU_TO_MEM 	0
#define LGRP_RSRC_CPU           0       /* CPU resources */
#define LGRP_RSRC_MEM           1       /* memory resources */

#define LGRP_RESOURCES(c, lgrp, type) \
	{ errno = EINVAL; LGRP_BADVAL(); }

/*
 * Simulate lgrp_latency_cookie() which just fails. This macro is never called
 * and we just define it so that the C compiler will not complain about the
 * missing symbol.
 */
#define	lgrp_latency_cookie(c, f, t, b) (errno = EINVAL, -1)

#else
#define	LGRP_RESOURCES(c, lgrp, type) { \
	int nr;				\
	lgrp_id_t *lgrps;		\
					\
	errno = 0;			\
	nr = lgrp_resources(c, lgrp, NULL, 0, type);	\
	if (nr < 0)			\
		LGRP_BADVAL();		\
	if (GIMME_V == G_SCALAR)	\
		XSRETURN_IV(nr);	\
	if (nr == 0) {			\
		XSRETURN_EMPTY;		\
	} else if (New(0, lgrps, nr, lgrp_id_t) == NULL) {	\
		errno = ENOMEM;		\
		LGRP_BADVAL();		\
	} else {			\
		nr = lgrp_resources(c, lgrp, lgrps, nr, type);	\
		PUSHARRAY(lgrps, nr);	\
		Safefree(lgrps);	\
	}				\
}
#endif

/*
 * Special version of lgrp_latency_cookie(). Use lgrp_latency() for liblgrp V1
 * and lgrp_latency_cookie for V2.
 */
static int
_lgrp_latency_cookie(lgrp_cookie_t cookie, lgrp_id_t from, lgrp_id_t to,
				   int between)
{
	return (LGRP_VER_CURRENT < 2 ?
	    lgrp_latency(from, to) :
	    lgrp_latency_cookie(cookie, from, to, between));
}

/*
 * Most functions in liblgrp return -1 on failure. The perl equivalent returns
 * 'undef' instead. The macro should be call after the RETVAL is set to the
 * return value of the function.
 */
#define	RETURN_UNDEF_IF_FAIL { if (RETVAL < 0) XSRETURN_UNDEF; }

/*
 * End of C part, start of XS part.
 *
 * The XS code exported to perl is below here.  Note that the XS preprocessor
 * has its own commenting syntax, so all comments from this point on are in
 * that form.
 */

MODULE = Sun::Solaris::Lgrp PACKAGE = Sun::Solaris::Lgrp
PROTOTYPES: ENABLE

 #
 # Define any constants that need to be exported.  By doing it this way we can
 # avoid the overhead of using the DynaLoader package, and in addition constants
 # defined using this mechanism are eligible for inlining by the perl
 # interpreter at compile time.
 #
BOOT:
	{
	HV *stash;

	stash = gv_stashpv("Sun::Solaris::Lgrp", TRUE);
	newCONSTSUB(stash, "LGRP_AFF_NONE", newSViv(LGRP_AFF_NONE));
	newCONSTSUB(stash, "LGRP_AFF_STRONG", newSViv(LGRP_AFF_STRONG));
	newCONSTSUB(stash, "LGRP_AFF_WEAK", newSViv(LGRP_AFF_WEAK));
	newCONSTSUB(stash, "LGRP_VER_CURRENT", newSViv(LGRP_VER_CURRENT));
	newCONSTSUB(stash, "LGRP_VER_NONE", newSViv(LGRP_VER_NONE));
	newCONSTSUB(stash, "LGRP_NONE", newSViv(LGRP_NONE));
	newCONSTSUB(stash, "LGRP_RSRC_CPU", newSViv(LGRP_RSRC_CPU));
	newCONSTSUB(stash, "LGRP_RSRC_MEM", newSViv(LGRP_RSRC_MEM));
	newCONSTSUB(stash, "LGRP_CONTENT_HIERARCHY",
			newSViv(LGRP_CONTENT_HIERARCHY));
	newCONSTSUB(stash, "LGRP_CONTENT_DIRECT", newSViv(LGRP_CONTENT_DIRECT));
	newCONSTSUB(stash, "LGRP_VIEW_CALLER", newSViv(LGRP_VIEW_CALLER));
	newCONSTSUB(stash, "LGRP_VIEW_OS", newSViv(LGRP_VIEW_OS));
	newCONSTSUB(stash, "LGRP_MEM_SZ_FREE", newSViv(LGRP_MEM_SZ_FREE));
	newCONSTSUB(stash, "LGRP_MEM_SZ_INSTALLED",
			newSViv(LGRP_MEM_SZ_INSTALLED));
	newCONSTSUB(stash, "LGRP_CONTENT_ALL", newSViv(LGRP_CONTENT_ALL));
	newCONSTSUB(stash, "LGRP_LAT_CPU_TO_MEM", newSViv(LGRP_LAT_CPU_TO_MEM));
	newCONSTSUB(stash, "P_PID", newSViv(P_PID));
	newCONSTSUB(stash, "P_LWPID", newSViv(P_LWPID));
	newCONSTSUB(stash, "P_MYID", newSViv(P_MYID));
	}

 #
 # The code below uses POSTCALL directive which allows to return 'undef'
 # whenever a C function returns a negative value.
 #


 #
 # lgrp_init([view])
 # Use LGRP_VIEW_OS as the default view.
 #
lgrp_cookie_t
lgrp_init(lgrp_view_t view = LGRP_VIEW_OS)
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

lgrp_view_t
lgrp_view(cookie)
       lgrp_cookie_t cookie
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

lgrp_affinity_t
lgrp_affinity_get(idtype, id, lgrp)
	idtype_t idtype;
	id_t id;
	lgrp_id_t lgrp;
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

int
lgrp_affinity_set(idtype, id, lgrp, affinity)
	idtype_t idtype;
	id_t id;
	lgrp_id_t lgrp;
	lgrp_affinity_t affinity;
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;
	XSRETURN_YES;

int
lgrp_cookie_stale(cookie)
	lgrp_cookie_t cookie;
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

int
lgrp_fini(cookie)
	lgrp_cookie_t cookie;
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;
	XSRETURN_YES;

lgrp_id_t
lgrp_home(idtype, id)
	idtype_t idtype;
	id_t id;
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

int
lgrp_latency(lgrp_id_t from,lgrp_id_t to)
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

lgrp_mem_size_t
lgrp_mem_size(cookie, lgrp, type, content)
	lgrp_cookie_t	cookie
	lgrp_id_t	lgrp
	int		type
	lgrp_content_t	content
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

int
lgrp_nlgrps(cookie)
	lgrp_cookie_t cookie;
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

lgrp_id_t
lgrp_root(cookie)
	lgrp_cookie_t cookie
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;

int
lgrp_version(int version = LGRP_VER_NONE)

 #
 # lgrp_latency_cookie calls our internal wrapper  _lgrp_latency_cookie() which
 # works for both old and new versions of liblgrp.
 #
int
lgrp_latency_cookie(lgrp_cookie_t cookie, lgrp_id_t from, lgrp_id_t to, int between = 0)
  CODE:
	RETVAL = _lgrp_latency_cookie(cookie, from, to, between);
  POSTCALL:
	RETURN_UNDEF_IF_FAIL;
  OUTPUT:
	RETVAL

 #
 # Functions below convert C arrays into Perl lists. They use XS PPCODE
 # directive to avoid implicit RETVAL assignments and manipulate perl
 # stack directly.
 #
 # When called in scalar context functions return the number of elements
 # in the list or undef on failure.
 #
 # The PUSHARRAY() macro defined above pushes all values from the C array to
 # the perl stack.
 #

 #
 # @children = lgrp_children($cookie, $parent).
 #
void
lgrp_children(cookie, lgrp)
	lgrp_cookie_t cookie;
	lgrp_id_t lgrp;
  PREINIT:
	lgrp_id_t *lgrps;
	int	count;
  PPCODE:
	errno = 0;
	if ((count = lgrp_children(cookie, lgrp, NULL, 0)) < 0)
		LGRP_BADVAL();

	if (GIMME_V == G_SCALAR)
		XSRETURN_IV(count);

	if (count > 0) {
		if (New(0, lgrps, count, lgrp_id_t) == NULL) {
			errno = ENOMEM;
			LGRP_BADVAL();
		} else {
			count = lgrp_children(cookie, lgrp, lgrps, count);
			PUSHARRAY(lgrps, count);
			Safefree(lgrps);
		}
	}

 #
 # @parents = lgrp_parents($cookie, $lgrp).
 #
void
lgrp_parents(cookie, lgrp)
	lgrp_cookie_t cookie;
	lgrp_id_t lgrp;
  PREINIT:
	lgrp_id_t *lgrps;
	int count;
  PPCODE:
	errno = 0;
	if ((count = lgrp_parents(cookie, lgrp, NULL, 0)) < 0)
		LGRP_BADVAL();

	if (GIMME_V == G_SCALAR)
		XSRETURN_IV(count);

	if (count > 0) {
		if (New(0, lgrps, count, lgrp_id_t) == NULL) {
			errno = ENOMEM;
			LGRP_BADVAL();
		} else {
			count = lgrp_parents(cookie, lgrp, lgrps, count);
			PUSHARRAY(lgrps, count);
			Safefree(lgrps);
		}
	}

 #
 # @parents = lgrp_cpus($cookie, $lgrp, $content).
 # Content should be LGRP_CONTENT_HIERARCHY or LGRP_CONTENT_ALL or
 # 	LGRP_CONTENT_DIRECT
void
lgrp_cpus(cookie, lgrp, content)
	lgrp_cookie_t cookie;
	lgrp_id_t lgrp;
	lgrp_content_t content;
  PREINIT:
	int ncpus;
	processorid_t *cpus;
  PPCODE:
	errno = 0;
	if ((ncpus = lgrp_cpus(cookie, lgrp, NULL, 0, content)) < 0)
		LGRP_BADVAL();

	if (GIMME_V == G_SCALAR)
		XSRETURN_IV(ncpus);

	if (ncpus > 0) {
		if (New(0, cpus, ncpus, processorid_t) == NULL) {
			errno = ENOMEM;
			LGRP_BADVAL();
		} else {
			ncpus = lgrp_cpus(cookie, lgrp, cpus, ncpus, content);
			PUSHARRAY(cpus, ncpus);
			Safefree(cpus);
		}
	}

void
lgrp_resources(cookie, lgrp, type)
	lgrp_cookie_t cookie;
	lgrp_id_t lgrp;
	int type;
  PPCODE:
	LGRP_RESOURCES(cookie, lgrp, type);
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

include $(SRC)/Makefile.master

SUBDIRS = $(MACH64)

all :		TARGET = all
install :	TARGET = install
clean :	TARGET = clean
clobber :	TARGET = clobber

all install clean clobber: $(SUBDIRS)

$(SUBDIRS): FRC
	@cd $@; pwd; $(MAKE) $(TARGET)

FRC:
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = Lgrp

include $(SRC)/cmd/perl/Makefile.perl

LDLIBS += -llgrp

CERRWARN += -Wno-type-limits

XSUBPPFLAGS = -typemap typemap

MAPFILES = ../mapfile-vers
#
# 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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#
# ident	"%Z%%M%	%I%	%E% SMI"
#

Licensing
---------
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.

Availability
------------
This module is only available for Solaris 9u6 onwards.

Description
-----------
This module provided access to the Solaris locality group library
liblgrp(3LIB). It provides both functional and object-oriented interface to all
functions defined in liblgrp(3LIB).

The t directory contains two files: Lgrp.t and Lgrp_api.t which contain lots
of examples (and serve as tests).

Installation
------------

1. Uncompress and untar the archive
2. cd to the module directory
3. perl Makefile.PL; make test; make install

If you are using gcc and wish to build this module against the perl shipped as
part of Solaris, see the Solaris-PerlGcc module, also available from CPAN.
#
# 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.
#

This module is released as Public Source via the Comprehensive Perl Archive
Network (http://www.cpan.org).  If it is updated for any reason, a new
release should be pushed to CPAN.

The version number of this module is derived from the $VERSION variable in
Lgrp.pm.  If anything under this directory is modified, $VERSION should be 
changed in Lgrp.pm to update the module version number correctly.  If this 
is not done, it will not be possible to upload the generated archive to CPAN, 
as CPAN requires that uploaded archives have unique names.

To prepare the contents of the directory for release, they should be packaged
up as a .tar.gz archive.  The procedure for this is:

$ /usr/perl5/bin/perl Makefile.PL
$ make tardist

This will produce the file for upload to CPAN.  Contact cpan-support@sun.com
for details of how to do this.
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#

# Copyright 2022, Richard Lowe.

include ../Makefile.com
include $(SRC)/cmd/perl/Makefile.perl.64

all: $(PERLEXT)
install: $(ROOTPERLEXT) $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright (c) 2014 Racktop Systems.
#

$mapfile_version 2

SYMBOL_SCOPE {
    global:
	boot_Sun__Solaris__Lgrp;
	XS_Sun__Solaris__Lgrp_lgrp_affinity_get;
	XS_Sun__Solaris__Lgrp_lgrp_affinity_set;
	XS_Sun__Solaris__Lgrp_lgrp_children;
	XS_Sun__Solaris__Lgrp_lgrp_cookie_stale;
	XS_Sun__Solaris__Lgrp_lgrp_cpus;
	XS_Sun__Solaris__Lgrp_lgrp_fini;
	XS_Sun__Solaris__Lgrp_lgrp_home;
	XS_Sun__Solaris__Lgrp_lgrp_init;
	XS_Sun__Solaris__Lgrp_lgrp_latency;
	XS_Sun__Solaris__Lgrp_lgrp_latency_cookie;
	XS_Sun__Solaris__Lgrp_lgrp_mem_size;
	XS_Sun__Solaris__Lgrp_lgrp_nlgrps;
	XS_Sun__Solaris__Lgrp_lgrp_parents;
	XS_Sun__Solaris__Lgrp_lgrp_resources;
	XS_Sun__Solaris__Lgrp_lgrp_root;
	XS_Sun__Solaris__Lgrp_lgrp_version;
	XS_Sun__Solaris__Lgrp_lgrp_view;
    local:
	*;
};
#
# 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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#

#
# Sun::Solaris::Lgrp documentation.
#

=head1 NAME

Lgrp - Perl interface to Solaris liblgrp library.

=head1 SYNOPSIS

  use Sun::Solaris::Lgrp qw(:ALL);

  # initialize lgroup interface
  my $cookie = lgrp_init(LGRP_VIEW_OS | LGRP_VIEW_CALLER);
  my $l = Sun::Solaris::Lgrp->new(LGRP_VIEW_OS | LGRP_VIEW_CALLER);

  my $version = lgrp_version(LGRP_VER_CURRENT | LGRP_VER_NONE);
  $version = $l->version(LGRP_VER_CURRENT | LGRP_VER_NONE);

  $home = lgrp_home(P_PID, P_MYID);
  $home = l->home(P_PID, P_MYID);

  lgrp_affinity_set(P_PID, $pid, $lgrp,
	LGRP_AFF_STRONG | LGRP_AFF_WEAK | LGRP_AFF_NONE);
  $l->affinity_set(P_PID, $pid, $lgrp,
	LGRP_AFF_STRONG | LGRP_AFF_WEAK | LGRP_AFF_NONE);

  my $affinity = lgrp_affinity_get(P_PID, $pid, $lgrp);
  $affinity = $l->affinity_get(P_PID, $pid, $lgrp);

  my $nlgrps = lgrp_nlgrps($cookie);
  $nlgrps = $l->nlgrps();

  my $root = lgrp_root($cookie);
  $root = l->root();

  $latency = lgrp_latency($lgrp1, $lgrp2);
  $latency = $l->latency($lgrp1, $lgrp2);

  my @children = lgrp_children($cookie, $lgrp);
  @children = l->children($lgrp);

  my @parents = lgrp_parents($cookie, $lgrp);
  @parents = l->parents($lgrp);

  my @lgrps = lgrp_lgrps($cookie);
  @lgrps = l->lgrps();

  @lgrps = lgrp_lgrps($cookie, $lgrp);
  @lgrps = l->lgrps($lgrp);

  my @leaves = lgrp_leaves($cookie);
  @leaves = l->leaves();

  my $is_leaf = lgrp_isleaf($cookie, $lgrp);
  $is_leaf = $l->is_leaf($lgrp);

  my @cpus = lgrp_cpus($cookie, $lgrp,
	LGRP_CONTENT_HIERARCHY | LGRP_CONTENT_DIRECT);
  @cpus = l->cpus($lgrp, LGRP_CONTENT_HIERARCHY | LGRP_CONTENT_DIRECT);

  my $memsize = lgrp_mem_size($cookie, $lgrp,
	LGRP_MEM_SZ_INSTALLED | LGRP_MEM_SZ_FREE,
	LGRP_CONTENT_HIERARCHY | LGRP_CONTENT_DIRECT);
  $memsize = l->mem_size($lgrp,
	LGRP_MEM_SZ_INSTALLED | LGRP_MEM_SZ_FREE,
	LGRP_CONTENT_HIERARCHY | LGRP_CONTENT_DIRECT);

  my $is_stale = lgrp_cookie_stale($cookie);
  $stale = l->stale();

  lgrp_fini($cookie);

  # The following is available for API version greater than 1:

  my @lgrps = lgrp_resources($cookie, $lgrp, LGRP_RSRC_CPU);

  # Get latencies from cookie
  $latency = lgrp_latency_cookie($cookie, $from, $to);

=head1 DESCRIPTION

This module provides access to the C<liblgrp(3LIB)> library and to various
constants and functions defined in C<sys/lgrp_sys.h> header file. It provides
both the procedural and object interface to the library. The procedural
interface requires (in most cases) passing a transparent cookie around. The
object interface hides all the cookie manipulations from the user.

Functions returning scalar value indicate error by returning B<undef>. The
caller may examine the B<$!> variable to get the C<errno> value.

Functions returning list value return the number of elements in the list when
called in scalar context. In case of error the empty list is return in the array
context and B<undef> is returned in the scalar context.

=head2 CONSTANTS

The constants are exported with B<:CONSTANTS> or B<:ALL> tags:

  use Sun::Solaris::Lgrp ':ALL';

or

  use Sun::Solaris::Lgrp ':CONSTANTS';

The following constants are available for use in Perl programs:


  LGRP_NONE

  LGRP_VER_CURRENT
  LGRP_VER_NONE

  LGRP_VIEW_CALLER
  LGRP_VIEW_OS

  LGRP_AFF_NONE
  LGRP_AFF_STRONG
  LGRP_AFF_WEAK

  LGRP_CONTENT_DIRECT
  LGRP_CONTENT_HIERARCHY

  LGRP_MEM_SZ_FREE
  LGRP_MEM_SZ_INSTALLED

  LGRP_RSRC_CPU (1)
  LGRP_RSRC_MEM (1)
  LGRP_CONTENT_ALL (1)
  LGRP_LAT_CPU_TO_MEM(1)

  P_PID
  P_LWPID
  P_MYID

(1) Available for versions of the liblgrp(3LIB) API greater than 1.

=head2 functions

A detailed description of each function follows. Since this module is intended
to provide a Perl interface to the routines in L<liblgrp(3LIB)>, a very short
description is given for the corresponding functions in this module and a
reference is given to the complete description in the L<liblgrp(3LIB)> man
pages. Any differences or additional functionality in the Perl module are
highlighted and fully documented here.

=over

=item lgrp_init([LGRP_VIEW_CALLER | LGRP_VIEW_OS])

The function initializes the lgroup interface and takes a snapshot of the lgroup
hierarchy with the given view. Given the view, L<lgrp_init()> returns a cookie
representing this snapshot of the lgroup hierarchy. This cookie should be used
with other routines in the lgroup interface needing the lgroup hierarchy. The
L<lgrp_fini()> function should be called with the cookie when it is no longer
needed. Unlike L<lgrp_init (3LGRP)>, C<LGRP_VIEW_OS> is assumed as the default if
no view is provided.

Upon successful completion, L<lgrp_init()> returns a cookie. Otherwise it returns
B<undef> and sets B<$!> to indicate the error.

See L<lgrp_init(3LGRP)> for more information.

=item lgrp_fini($cookie)

The function takes a cookie, frees the snapshot of the lgroup hierarchy created
by L<lgrp_init()>, and cleans up anything else set up by L<lgrp_init()>. After
this function is called, the cookie returned by the lgroup interface might no
longer be valid and should not be used.

Upon successful completion, 1 is returned. Otherwise, B<undef> is returned and
B<$!> is set to indicate the error.

See L<lgrp_fini(3LGRP)> for more information.

=item lgrp_view($cookie)

The function takes a cookie representing the snapshot of the lgroup hierarchy
and returns the snapshot's view of the lgroup hierarchy.

If the given view is C<LGRP_VIEW_CALLER>, the snapshot contains only the
resources that are available to the caller (such as those with respect to
processor sets).  When the view is C<LGRP_VIEW_OS>, the snapshot contains what
is available to the operating system.

Upon succesful completion, the function returns the view for the snapshot of the
lgroup hierarchy represented by the given cookie. Otherwise, B<undef> is
returned and C<$!> is set.

See L<lgrp_view(3LGRP)> for more information.

=item lgrp_home($idtype, $id)

Returns the home lgroup for the given process or thread. The B<$idtype> argument
should be C<P_PID> to specify a process and the B<$id> argument should be its
process id. Otherwise, the B<$idtype> argument should be C<P_LWPID> to specify a
thread and the B<$id> argument should be its LWP id. The value C<P_MYID> can be
used for the id argument to specify the current process or thread.

Upon successful completion, C<lgrp_home()> returns the id of the home lgroup of
the specified process or thread. Otherwise, B<undef> is returned and B<$!> is
set to indicate the error.

See L<lgrp_home(3LGRP)> for more information.

=item lgrp_cookie_stale($cookie)

Upon successful completion, the function returns whether the cookie is
stale. Otherwise, it returns B<undef> and sets B<$!> to indicate the error.

The L<lgrp_cookie_stale()> function will fail with C<EINVAL> if the cookie is
not valid.

See L<lgrp_cookie_stale(3LGRP)> for more information.

=item lgrp_cpus($cookie, $lgrp, $context)

The function takes a cookie representing a snapshot of the lgroup hierarchy and
returns the list of CPUs in the lgroup specified by B<$lgrp>. The B<$context>
argument should be set to one of the following values to specify whether the
direct contents or everything in this lgroup including its children should be
returned:

=over

=item LGRP_CONTENT_HIERARCHY

Everything within this hierarchy.

=item LGRP_CONTENT_DIRECT

Directly contained in lgroup.

=back

When called in scalar context, L<lgrp_cpus()> function returns the number of
CPUs, contained in the specified lgroup.

In case of error B<undef> is returned in scalar context and B<$!> is set to
indicate the error. In list context the empty list is returned and B<$!> is set.

See L<lgrp_cpus(3LGRP)> for more information.

=item lgrp_children($cookie, $lgrp)

The function takes a cookie representing a snapshot of the lgroup hierarchy and
returns the list of lgroups that are children of the specified lgroup.

When called in scalar context, L<lgrp_children()> function returns the number of
children lgroups for the specified lgroup.

In case of error B<undef> or empty list is returned and B<$!> is set to indicate
the error.

See L<lgrp_children(3LGRP)> for more information.

=item lgrp_parents($cookie, $lgrp)

The function takes a cookie representing a snapshot of the lgroup hierarchy and
returns the list of parent of the specified lgroup.

When called in scalar context, L<lgrp_parents()> function returns the number of
parent lgroups for the specified lgroup.

In case of error B<undef> or empty list is returned and B<$!> is set to indicate
the error.

See L<lgrp_parents(3LGRP)> for more information.

=item lgrp_nlgrps($cookie)

The function takes a cookie representing a snapshot of the lgroup hierarchy.  It
returns the number of lgroups in the hierarchy where the number is always at
least one.

In case of error B<undef> is returned and B<$!> is set to EINVAL indicatng that
the cookie is not valid.

See L<lgrp_nlgrps(3LGRP)> for more information.

=item lgrp_root($cookie)

The function returns the root lgroup ID.  In case of error B<undef> is returned
and B<$!> is set to EINVAL indicatng that the cookie is not valid.

See L<lgrp_root(3LGRP)> for more information.

=item lgrp_mem_size($cookie, $lgrp, $type, $content)

The function takes a cookie representing a snapshot of the lgroup hierarchy. The
function returns the memory size of the given lgroup in bytes. The B<$type>
argument should be set to one of the following values:

=over

=item LGRP_MEM_SZ_FREE

Free memory.

=item LGRP_MEM_SZ_INSTALLED

Installed memory.

=back

The B<$content> argument should be set to one of the following values to specify
whether the direct contents or everything in this lgroup including its children
should be returned:

=over

=item LGRP_CONTENT_HIERARCHY

Everything within this hierarchy.

=item LGRP_CONTENT_DIRECT

Directly contained in lgroup.

=back

The total sizes include all the memory in the lgroup including its children,
while the others reflect only the memory contained directly in the given lgroup.

Upon successful completion, the size in bytes is returned. Otherwise, B<undef>
is returned and B<$!> is set to indicate the error.

See L<lgrp_mem_size(3LGRP)> for more information.

=item lgrp_version([$version])

The function takes an interface version number, B$version>, as an argument and
returns an lgroup interface version. The B<$version> argument should be the
value of C<LGRP_VER_CURRENT> or C<LGRP_VER_NONE> to find out the current lgroup
interface version on the running system.

If B<$version> is still supported by the implementation, then L<lgrp_version()>
returns the requested version. If C<LGRP_VER_NONE> is returned, the
implementation cannot support the requested version. 

If B<$version> is C<LGRP_VER_NONE>, L<lgrp_version()> returns the current version of
the library.

The following example  tests  whether  the  version  of  the
interface used by the caller is supported:

    lgrp_version(LGRP_VER_CURRENT) == LGRP_VER_CURRENT or
    	die("Built with unsupported lgroup interface");

See L<lgrp_version(3LGRP)> for more information.

=item lgrp_affinity_set($idtype, $id, $lgrp, $affinity)

The function sets of LWPs specified by the B<$idtype> and B<$id> arguments have
for the given lgroup.

The function sets the affinity that the LWP or set of LWPs specified by $idtype
and $id have for the given lgroup. The lgroup affinity can be set to
C<LGRP_AFF_STRONG>, C<LGRP_AFF_WEAK>, or C<LGRP_AFF_NONE>.

If the B<$idtype> is C<P_PID>, the affinity is retrieved for one of the LWPs in
the process or set for all the LWPs of the process with process id (PID) B<$id>.
The affinity is retrieved or set for the LWP of the current process with LWP id
$id if idtype is C<P_LWPID>. If $id is C<P_MYID>, then the current LWP or
process is specified.

There are different levels of affinity that can be specified by a thread for a
particuliar lgroup.  The levels of affinity are the following from strongest to
weakest:

=over

=item LGRP_AFF_STRONG

Strong affinity.

=item LGRP_AFF_WEAK

Weak affinity.

=item LGRP_AFF_NONE

No affinity.

=back

Upon successful completion, L<lgrp_affinity_set()> return 1.  Otherwise, it
returns B<undef> and set B<$!> to indicate the error.

See L<lgrp_affinity_set(3LGRP)> for more information.

=item lgrp_affinity_get($idtype, $id, $lgrp)

The function returns the affinity that the LWP has to a given lgrp. See
L<lgrp_affinity_get()> for detailed description.

See L<lgrp_affinity_get(3LGRP)> for more information.

=item lgrp_latency_cookie($cookie, $from, $to, [$between=LGRP_LAT_CPU_TO_MEM])

The function takes a cookie representing a snapshot of the lgroup hierarchy and
returns the latency value between a hardware resource in the $from lgroup to a
hardware resource in the B<$to> lgroup. If B<$from> is the same lgroup as $to, the
latency value within that lgroup is returned.

The optional B<between> argument should be set to C<LGRP_LAT_CPU_TO_MEM> to specify
between which hardware resources the latency should be measured. Currently the
only valid value is C<LGRP_LAT_CPU_TO_MEM> which represents latency from CPU to
memory.

Upon successful completion, lgrp_latency_cookie() return 1. Otherwise, it
returns B<undef> and set B<$!> to indicate the error. For LGRP API version 1 the
L<lgrp_latency_cookie()> is an alias for L<lgrp_latency()>.

See L<lgrp_latency_cookie(3LGRP)> for more information.

=item lgrp_latency($from, $to)

The function is similiar to the L<lgrp_latency_cookie()> function, but returns the
latency between the given lgroups at the given instant in time.  Since lgroups
may be freed and reallocated, this function may not be able to provide a
consistent answer across calls.  For that reason, it is recommended that
L<lgrp_latency_cookie()> function be used in its place.

See L<lgrp_latency(3LGRP)> for more information.

=item lgrp_resources($cookie, $lgrp, $type)

Return the list of lgroups directly containing resources of the specified type.
The resources are represented by a set of lgroups in which each lgroup directly
contains CPU and/or memory resources.

The type can be specified as

=over

=item C<LGRP_RSRC_CPU>

CPU resources

=item C<LGRP_RSRC_MEM>

Memory resources

=back

In case of error B<undef> or empty list is returned and B<$!> is set to indicate
the error.

This function is only available for API version 2 and will return B<undef> or
empty list for API version 1 and set $! to C<EINVAL>.

See C<lgrp_resources(3LGRP)> for more information.

=item lgrp_lgrps($cookie, [$lgrp])

Returns list of all lgroups in a hierarchy starting from $lgrp. If B<$lgrp> is
not specified, uses the value of lgrp_root($cookie). Returns the empty list on
failure.

When called in scalar context, returns the total number of lgroups in the
system.

=item lgrp_leaves($cookie, [$lgrp])

Returns list of all leaf lgroups in a hierarchy starting from $lgrp. If $lgrp is
not specified, uses the value of lgrp_root($cookie). Returns B<undef> or empty
list on failure.

When called in scalar context, returns the total number of leaf lgroups in the
system.

=item lgrp_isleaf($cookie, $lgrp)

Returns B<True> if $lgrp is leaf (has no children), B<False> otherwise.

=back

=head2 Object Methods

=over

=item new([$view])

Creates a new Sun::Solaris::Lgrp object. An optional argument is passed to
L<lgrp_init()> function. By default uses C<LGRP_VIEW_OS>.

=item cookie()

Returns a transparent cookie that may be passed to functions accepting cookie.

=item version([$version])

Without the argument returns the current version of the L<liblgrp(3LIB)>
library. This is a wrapper for L<lgrp_version()> with C<LGRP_VER_NONE> as the
default version argument.

=item stale()

Returns B<T> if the lgroup information in the object is stale, B<F>
otherwise. It is a wrapper for L<lgrp_cookie_stale()>.

=item view()

Returns the snapshot's view of the lgroup hierarchy. It is a wrapper for
L<lgrp_view()>.

=item root()

Returns the root lgroup. It is a wrapper for L<lgrp_root()>.

=item children($lgrp)

Returns the list of lgroups that are children of the specified lgroup. This is a
wrapper for L<lgrp_children()>.

=item parents($lgrp)

Returns the list of lgroups that are parents of the specified lgroup. This is a
wrapper for L<lgrp_parents()>.

=item nlgrps()

Returns the number of lgroups in the hierarchy. This is a wrapper for
L<lgrp_nlgrps()>.

=item mem_size($lgrp, $type, $content)

Returns the memory size of the given lgroup in bytes. This is a wrapper for
L<lgrp_mem_size()>.

=item cpus($lgrp, $context)

Returns the list of CPUs in the lgroup specified by $lgrp. This is a wrapper for
L<lgrp_cpus()>.

=item resources($lgrp, $type)

Returns the list of lgroups directly containing resources of the specified
type. This is a wrapper for L<lgrp_resources()>.

=item home($idtype, $id)

Returns the home lgroup for the given process or thread. This is a wrapper for
L<lgrp_home()>.

=item affinity_get($idtype, $id, $lgrp)

Returns the affinity that the LWP has to a given lgrp. This is a wrapper for
L<lgrp_affinity_get()>.

=item affinity_set($idtype, $id, $lgrp, $affinity)

Sets of LWPs specified by the $idtype and $id arguments have for the given lgroup.
This is a wrapper for L<lgrp_affinity_set()>.

=item lgrps([$lgrp])

Returns list of all lgroups in a hierarchy starting from $lgrp (or the
L<lgrp_root()> if $lgrp is not specified). This is a wrapper for L<lgrp_lgrps()>.

=item leaves([$lgrp])

Returns list of all leaf lgroups in a hierarchy starting from B<$lgrp>. If $lgrp
is not specified, uses the value of lgrp_root(). This is a wrapper for
L<lgrp_leaves()>.

=item isleaf($lgrp)

Returns B<True> if B<$lgrp> is leaf (has no children), B<False> otherwise.
This is a wrapper for L<lgrp_isleaf()>.

=item latency($from, $to)

Returns the latency value between a hardware resource in the $from lgroup to a
hardware resource in the B<$to> lgroup. It will use L<lgrp_latency()> for
version 1 of liblgrp(3LIB) and L<lgrp_latency_cookie()> for newer versions.

=back

=head2 EXPORTS

By default nothing is exported from this module. The following tags can be used
to selectively import constants and functions defined in this module:

=over

=item :LGRP_CONSTANTS

LGRP_AFF_NONE, LGRP_AFF_STRONG, LGRP_AFF_WEAK, LGRP_CONTENT_DIRECT,
LGRP_CONTENT_HIERARCHY, LGRP_MEM_SZ_FREE, LGRP_MEM_SZ_INSTALLED,
LGRP_VER_CURRENT, LGRP_VER_NONE, LGRP_VIEW_CALLER, LGRP_VIEW_OS,
LGRP_NONE, LGRP_RSRC_CPU, LGRP_RSRC_MEM, LGRP_CONTENT_ALL,
LGRP_LAT_CPU_TO_MEM.

=item :PROC_CONSTANTS

P_PID, P_LWPID P_MYID

=item :CONSTANTS

:LGRP_CONSTANTS, :PROC_CONSTANTS

=item :FUNCTIONS

lgrp_affinity_get(), lgrp_affinity_set(), lgrp_children(), lgrp_cookie_stale(),
lgrp_cpus(), lgrp_fini(), lgrp_home(), lgrp_init(), lgrp_latency(),
lgrp_latency_cookie(), lgrp_mem_size(), lgrp_nlgrps(), lgrp_parents(),
lgrp_root(), lgrp_version(), lgrp_view(), lgrp_resources(),
lgrp_lgrps(), lgrp_leaves(), lgrp_isleaf(), lgrp_lgrps(), lgrp_leaves().

=item :ALL

:CONSTANTS, :FUNCTIONS

=back

=head2 Error values

The functions in this module return B<undef> or an empty list when an underlying
library function fails. The B<$!> is set to provide more information values for
the error. The following error codes are possible:

=over

=item EINVAL

The value supplied is not valid.

=item ENOMEM

There was not enough system memory to complete an operation.

=item EPERM

The effective user of the calling process does not have appropriate privileges,
and its real or effective user ID does not match the real or effective user ID
of one of the threads.

=item ESRCH

The specified  process or thread was not found.

=back

=head2 Difference in the API versions

The C<liblgrp(3LIB)> is versioned. The exact version which was used to compile a
module is available through B<lgrp_version> function.

Version 2 of the lgrpp_user API introduced the following constants and
functions, nbot present in version 1:

=over

=item C<LGRP_RSRC_CPU> constant

=item C<LGRP_RSRC_MEM> constant

=item C<LGRP_CONTENT_ALL> constant

=item C<LGRP_LAT_CPU_TO_MEM> constant

=item C<lgrp_resources()> function

=item C<lgrp_latency_cookie()> function

=back

The C<LGRP_RSRC_CPU> and C<LGRP_RSRC_MEM> are not defined for version 1. The
L<lgrp_resources()> function is defined for version 1 but always returns empty
list. The L<lgrp_latency_cookie()> function is an alias for lgrp_latency for
version 1.

=head1 ATTRIBUTES

See L<attributes(7)> for descriptions of the following attributes:

  ___________________________________________________________
 |       ATTRIBUTE TYPE        |       ATTRIBUTE VALUE       |
 |_____________________________|_____________________________|
 | Availability                | SUNWpl5u                    |
 |_____________________________|_____________________________|
 | Interface Stability         | Unstable                    |
 |_____________________________|_____________________________|


=head1 SEE ALSO

L<liblgrp(3LIB)>,
L<lgrp_affinity_get(3LGRP)>,
L<lgrp_affinity_set(3LGRP)>,
L<lgrp_children(3LGRP)>,
L<lgrp_cookie_stale(3LGRP)>,
L<lgrp_cpus(3LGRP)>,
L<lgrp_fini(3LGRP)>,
L<lgrp_home(3LGRP)>,
L<lgrp_init(3LGRP)>,
L<lgrp_latency(3LGRP)>,
L<lgrp_mem_size(3LGRP)>,
L<lgrp_nlgrps(3LGRP)>,
L<lgrp_parents(3LGRP)>,
L<lgrp_root(3LGRP)>,
L<lgrp_version(3LGRP)>,
L<lgrp_view(3LGRP)>,
L<lgrp_resources(3LGRP)>,
L<lgrp_latency_cookie(3LGRP)>,
L<attributes(7)>

=cut
#! /usr/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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#
# ident	"%Z%%M%	%I%	%E% SMI"
#

#
# Tests for Sun::Solaris::Lgrp API.
#
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl Lgrp.t'
#
# The test uses Test module which is available on Perl 5.6 and later.
#


use strict;
use warnings;
use Test;

# Tests to run
BEGIN { plan tests => 63 }

use Sun::Solaris::Lgrp ':ALL';

#
######################################################################

my ($home, $fail);

######################################################################
# Check that all exported constants can be accessed.
$fail = 0;
foreach my $constname (qw(
	LGRP_AFF_NONE LGRP_AFF_STRONG LGRP_AFF_WEAK LGRP_CONTENT_DIRECT
	LGRP_CONTENT_HIERARCHY LGRP_MEM_SZ_FREE
	LGRP_MEM_SZ_INSTALLED LGRP_VER_CURRENT LGRP_VER_NONE
	LGRP_VIEW_CALLER LGRP_VIEW_OS LGRP_RSRC_CPU LGRP_RSRC_MEM
	LGRP_CONTENT_ALL LGRP_LAT_CPU_TO_MEM)) {
  next if (eval "my \$a = $constname; 1");
  $fail++;
}

ok($fail,  0, 'All Constants defined' );

#########################

######################################################################
# Verify lgrp_version
##
my $version = lgrp_version(-1);
ok($version, LGRP_VER_NONE, 'incorrect lgrp version unsupported');

$version = lgrp_version(LGRP_VER_NONE);
ok($version, LGRP_VER_CURRENT, 'lgrp version is current');

$version = lgrp_version(LGRP_VER_CURRENT);
ok($version, LGRP_VER_CURRENT, 'support LGRP_VER_CURRENT version');
#
#######################################################################

######################################################################
# Verify that lgrp_init()/lgrp_fini work.
##
my $c = lgrp_init(LGRP_VIEW_CALLER);
ok($c) or
    die("lgrp_init: $!");

my $view = lgrp_view($c);

ok($view, LGRP_VIEW_CALLER, 'View is LGRP_VIEW_CALLER');

my $fin = lgrp_fini($c);
ok($fin);

# Try to free it again, it should fail.
$fin = lgrp_fini($c);
ok($fin, undef, 'lgrp_fini second time should fail');

$c = lgrp_init(LGRP_VIEW_OS);
ok($c) or
    die("lgrp_init: $!");

$view = lgrp_view($c);

ok($view, LGRP_VIEW_OS, 'View is LGRP_VIEW_OS');
#
######################################################################

######################################################################
# root should have ID 0.
##
my $root = lgrp_root($c);
ok($root, 0, 'root should have id zero');
#
######################################################################
# Verify lgrp_nlgrps()
##
my $nlgrps = lgrp_nlgrps($c);
ok($nlgrps);

my @lgrps = lgrp_lgrps($c);
ok(@lgrps);
ok(scalar @lgrps, $nlgrps, 'lgrp_nlgrps() should match number of lgrps');
ok($nlgrps, lgrp_lgrps($c), 'lgrp_lgrps() in scalar context is sane');

######################################################################
# All root children should have root as their one and only one parent
##
$fail = 0;
my @children = lgrp_children($c, $root);
ok(scalar @children, lgrp_children($c, $root), 'lgrp_children as scalar');
my @leaves = lgrp_leaves $c;
ok(scalar @leaves);
ok(scalar @leaves, lgrp_leaves $c);
ok(scalar @children <= scalar @leaves);

my @parents;

my $fail_lgrp_parents = 0;

foreach my $l (@children) {
    @parents = lgrp_parents($c, $l) or
	(print STDERR "# lgrp_parents: $!\n"), $fail++, last;
    my $nparents = @parents;
    my ($parent, @rest) = @parents;
    $fail++ if $parent != $root;
    $fail++ unless $nparents == 1;
    $fail_lgrp_parents++ if $nparents != lgrp_parents($c, $l);
}
ok($fail, 0, 'correct parents for children');
ok($fail_lgrp_parents, 0, 'correct lgrp_parents() as scalar');

######################################################################
# Illegal parents have no children
##
@children = lgrp_children($c, -1);
my $nchildren = lgrp_children($c, -1);
ok(scalar @children, 0, 'Illegal parents have no children');
# Same in scalar context
ok($nchildren, undef, 'No children means undef as scalar');

######################################################################
# root should have no parents.
##
@parents = lgrp_parents($c, $root);
ok(scalar @parents, 0, 'root should have no parents');
# Same in scalar context
ok(lgrp_parents($c, $root), 0);
#
######################################################################
# Illegal children have no paremts
##
@parents = lgrp_parents($c, -1);
my $nparents = lgrp_parents($c, -1);
ok(scalar @parents, 0, 'Illegal children have no paremts');
# Same in scalar context
ok($nparents, undef, 'No parents means undef as scalar');
#
######################################################################
# Root should have non-zero CPUs and memory size
##
my @cpus = lgrp_cpus($c, $root, LGRP_CONTENT_HIERARCHY);
my $ncpus = lgrp_cpus($c, $root, LGRP_CONTENT_HIERARCHY);
ok(scalar @cpus, $ncpus);
ok($ncpus);
ok(lgrp_mem_size($c, $root, LGRP_MEM_SZ_INSTALLED, LGRP_CONTENT_HIERARCHY));
my @ncpus_bad = lgrp_cpus($c, $root, -1);
ok(scalar @ncpus_bad, 0, 'Bad argument to lgrp_cpus should return empty');
my $ncpus_bad = lgrp_cpus($c, $root, -1);
ok($ncpus_bad, undef, 'Bad argument to lgrp_cpus should return undef');
#
######################################################################

######################################################################
# The cookie should not be stale
#
ok(! lgrp_cookie_stale($c));
#
######################################################################

######################################################################
# Can we call lgrp_latency?
# The latencies from lgrp_latency and lgrp_latency_cookie should match.
##
my $latency = lgrp_latency($root, $root);
ok(defined $latency);

my $latency1 = lgrp_latency_cookie($c, $root, $root);
ok(defined $latency1);
ok($latency, $latency1, 'Latencies should match');
#
######################################################################
# Can we call lgrp_resources?
##
my @lgrps_c = lgrp_resources($c, $root, LGRP_RSRC_CPU);
my $nresources = lgrp_resources($c, $root, LGRP_RSRC_CPU);
ok(!defined $nresources) if $version < 2;
ok(scalar @lgrps_c, 0) if $version < 2;
ok($nresources) if $version >= 2;
ok(@lgrps_c) if $version >= 2;

##
# lgrp_fini should always succeed.
ok(lgrp_fini($c));


######################################################################
# Now test Object-Oriented interface.
##
$c = Sun::Solaris::Lgrp->new or
    die "Lgrp->new(LGRP_VIEW_OS): $!";

ok($c->view, LGRP_VIEW_OS);
ok($c->stale, 0, 'cookie is not stale');
ok($nlgrps, $c->nlgrps, 'nlgrps');
my @lg1 = $c->lgrps;
ok(@lgrps, @lg1);
my@leaves1 = $c->leaves;
ok(@leaves, @leaves1) or
    print STDERR "# \@leaves: @leaves, \@leaves1: @leaves\n";
ok($root, $c->root);
@cpus = lgrp_cpus($c->cookie, $root, LGRP_CONTENT_HIERARCHY);
my @cpus1 = $c->cpus($root, LGRP_CONTENT_HIERARCHY);
ok(@cpus, @cpus1) or
    print STDERR "# \@cpus: @cpus, \@cpus1: @cpus1\n";
ok(lgrp_latency($root, $root), $c->latency($root, $root));
my @lgrps_c1 = $c->resources($root, LGRP_RSRC_CPU);
ok(@lgrps_c, @lgrps_c1);
ok(lgrp_version(LGRP_VER_NONE), $c->version);

#
######################################################################
# Can we call lgrp_home?
##
$home = lgrp_home(P_PID, P_MYID);
ok(defined($home));
my $home1 = $c->home(P_PID, P_MYID);
ok($home1 == $home);
$home1 = lgrp_home(P_LWPID, 1);
ok($home1 == $home);
$home1 = $c->home(P_LWPID, 1);
ok($home1 == $home);

#
######################################################################
# Can we call lgrp_affinity_set?
##
my $affinity;

ok(LGRP_AFF_WEAK);
ok(P_LWPID);

$affinity = $c->affinity_set(P_PID, P_MYID, $home, LGRP_AFF_WEAK);
ok($affinity);

$affinity = $c->affinity_set(P_LWPID, 1, $home, LGRP_AFF_WEAK);
ok($affinity);

$affinity = lgrp_affinity_set(P_PID, P_MYID, $home, LGRP_AFF_WEAK);
ok($affinity);

$affinity = lgrp_affinity_set(P_LWPID, 1, $home, LGRP_AFF_WEAK);
ok($affinity);

#
######################################################################
# Can we call lgrp_affinity_get?
##
$affinity = lgrp_affinity_get(P_PID, P_MYID, $home);
ok($affinity = LGRP_AFF_WEAK);

$affinity = lgrp_affinity_get(P_LWPID, 1, $home);
ok($affinity == LGRP_AFF_WEAK);

$affinity = $c->affinity_get(P_PID, P_MYID, $home);
ok($affinity == LGRP_AFF_WEAK);

$affinity = $c->affinity_get(P_LWPID, 1, $home);
ok($affinity == LGRP_AFF_WEAK);

#
######################################################################
# THE END!
#########
#! /usr/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!
#########
#
# 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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#
# ident	"%Z%%M%	%I%	%E% SMI"
#

TYPEMAP
	id_t				T_IV
	idtype_t			T_IV
	lgrp_affinity_t			T_IV
	lgrp_content_t			T_IV
	lgrp_cookie_t			T_UV
	lgrp_id_t			T_IV
	lgrp_view_t			T_UV
	lgrp_mem_size_t			T_IV
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = Pg

include $(SRC)/cmd/perl/Makefile.perl

PERLMOD = $(MODULE).pm

# Install module into arch independent directory
ROOTPERLMODDIR = $(ROOTPERLDIR)/lib/Sun/Solaris

.KEEP_STATE:

all:
install: $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#! /usr/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 (c) 2010, Oracle and/or its affiliates. All rights reserved.
#

#
# Pg.pm provides object-oriented interface to the Solaris
# Processor Group kstats
#
# See comments in the end
#

package Sun::Solaris::Pg;

use strict;
use warnings;
use Sun::Solaris::Kstat;
use Carp;
use Errno;
use List::Util qw(max sum);

our $VERSION = '1.1';

#
# Currently the OS does not have the root PG and PGs constitute a forest of
# small trees. This module gathers all such trees under one root with ID zero.
# If the root is present already, we do not use faked root.
#

my $ROOT_ID = 0;

#
# PG_NO_PARENT means that kstats have PG parent ID and it is set to -1
# PG_PARENT_UNDEF means that kstats have no PG parent ID
#
use constant {
	PG_NO_PARENT	=> -1,
	PG_PARENT_UNDEF => -2,
};

#
# Sorting order between different sharing relationships. This order is used to
# break ties between PGs with the same number of CPUs. If there are two PGs with
# the same set of CPUs, the one with the higher weight will be the parent of the
# one with the lower weight.
#
my %relationships_order = (
			   'CPU_PM_Idle_Power_Domain' => 1,
			   'Integer_Pipeline' => 2,
			   'Cache' => 3,
			   'CPU_PM_Active_Power_Domain' => 4,
			   'Floating_Point_Unit' => 5,
			   'Data_Pipe_to_memory' => 6,
			   'Memory' => 7,
			   'Socket' => 8,
			   'System' => 9,
			  );

#
# Object interface to the library. These are methods that can be used by the
# module user.
#

#
# Create a new object representing PG
# All the heavy lifting is performed by _init function.
# This function performs all the Perl blessing magic.
#
# The new() method accepts arguments in the form of a hash. The following
# subarguments are supported:
#
#   -cpudata	# Collect per-CPU data from kstats if this is T
#   -tags	# Match PGs to physical relationships if this is T
#   -swload	# Collect software CPU load if this is T
#   -retry	# how many times to retry PG initialization when it fails
#   -delay # Delay in seconds between retries
#
# The arguments are passed to _init().
#
sub new
{
	my $class = shift;
	my %args = @_;
	my $retry_count = $args{-retry} || 0;
	my $retry_delay = $args{-delay} || 1;

	my $self =  _init(@_);

	#
	# If PG initialization fails with EAGAIN error and the caller requested
	# retries, retry initialization.
	#
	for (; !$self && ($! == &Errno::EAGAIN) && $retry_count;
	     $retry_count--) {
		select(undef,undef,undef, $retry_delay);
		$self = _init(@_);
	}

	if ($self) {
		bless($self, $class) if defined($class);
		bless($self) unless defined($class);
	}

	return ($self);
}

#
# Functions below use internal function _pg_get which returns PG hash reference
# corresponding to PG ID specified or 'undef' if the PG can't be found.
#

#
# All methods return 'undef' in scalar context and an empty list in list
# context when unrecoverable errors are detected.
#

#
# Return the root ID of PG hierarchy
#
sub root
{
	scalar @_ == 1 or _usage("root(cookie)");
	my $self = shift;

	return unless $self->{PGTREE};

	return ($ROOT_ID);
}

#
# Return list of all pgs numerically sorted In scalar context return number of
# PGs
#
sub all
{
	scalar @_ == 1 or _usage("all(cookie)");
	my $self = shift;
	my $pgtree =  $self->{PGTREE} or return;
	my @ids = keys(%{$pgtree});

	return (wantarray() ? _nsort(@ids) : scalar @ids);
}

#
# Return list of all pgs by walking the tree depth first.
#
sub all_depth_first
{
	scalar @_ == 1 or _usage("all_depth_first(cookie)");
	my $self = shift;

	_walk_depth_first($self, $self->root());
}

#
# Return list of all pgs by walking the tree breadth first.
#
sub all_breadth_first
{
	scalar @_ == 1 or _usage("all_breadth_first(cookie)");
	my $self = shift;

	_walk_breadth_first($self, $self->root());
}

#
# Return list of CPUs in the PG specified
# CPUs returned are numerically sorted
# In scalar context return number of CPUs
#
sub cpus
{
	scalar @_ == 2 or _usage("cpus(cookie, pg)");
	my $pg = _pg_get(shift, shift) or return;
	my @cpus =  @{$pg->{cpus}};

	return (wantarray() ? _nsort(@cpus) : _collapse(@cpus));
}

#
# Return a parent for a given PG
# Returns undef if there is no parent
#
sub parent
{
	scalar @_ == 2 or _usage("parent(cookie, pg)");
	my $pg = _pg_get(shift, shift) or return;
	my $parent = $pg->{parent};

	return (defined($parent) && $parent >= 0 ? $parent : undef);
}

#
# Return list of children for a given PG
# In scalar context return list of children
#
sub children
{
	scalar @_ == 2 or _usage("children(cookie, pg)");
	my $pg = _pg_get(shift, shift) or return;

	my $children = $pg->{children} or return;
	my @children = @{$children};

	return (wantarray() ? _nsort(@children) : scalar @children);
}

#
# Return sharing name for the PG
#
sub sh_name
{
	scalar @_ == 2 or _usage("sh_name(cookie, pg)");
	my $pg = _pg_get(shift, shift) or return;
	return ($pg->{sh_name});
}

#
# Return T if specified PG ID is a leaf PG
#
sub is_leaf
{
	scalar @_ == 2 or _usage("is_leaf(cookie, pg)");
	my $pg = _pg_get(shift, shift) or return;
	return ($pg->{is_leaf});
}

#
# Return leaf PGs
#
sub leaves
{
	scalar @_ == 1 or _usage("leaves(cookie, pg)");

	my $self = shift;

	return (grep { is_leaf($self, $_) } $self->all());
}

#
# Update varying data in the snapshot
#
sub update
{
	scalar @_ == 1 or _usage("update(cookie)");

	my $self = shift;
	my $ks = $self->{KSTAT};

	$ks->update();

	my $pgtree = $self->{PGTREE};
	my $pg_info = $ks->{$self->{PG_MODULE}};

	#
	# Walk PG kstats and copy updated data from kstats to the snapshot
	#
	foreach my $id (keys %$pg_info) {
		my $pg = $pgtree->{$id} or next;

		my $pg_ks = _kstat_get_pg($pg_info, $id,
					  $self->{USE_OLD_KSTATS});
		return unless $pg_ks;

		#
		# Update PG from kstats
		#
		$pg->{util} = $pg_ks->{hw_util};
		$pg->{current_rate} = $pg_ks->{hw_util_rate};
		$pg->{util_rate_max} = $pg_ks->{hw_util_rate_max};
		$pg->{util_time_running} = $pg_ks->{hw_util_time_running};
		$pg->{util_time_stopped} = $pg_ks->{hw_util_time_stopped};
		$pg->{snaptime} = $pg_ks->{snaptime};
		$pg->{generation} = $pg_ks->{generation};
	}

	#
	# Update software load for each CPU
	#
	$self->{CPU_LOAD} = _get_sw_cpu_load($ks);

	#
	# Get hardware load per CPU
	#
	if ($self->{GET_CPU_DATA}) {
		_get_hw_cpu_load($self);
	}

	return (1);
}

#
# Return list of physical tags for the given PG
#
sub tags
{
	scalar @_ == 2 or _usage("tags(cookie, pg)");
	my $pg = _pg_get(shift, shift) or return;

	my $tags = $pg->{tags} or return;

	my @tags = _uniq(@{$tags});

	return (wantarray() ? @tags : join (',', @tags));
}

#
# Return list of sharing relationships in the snapshot Relationships are sorted
# by the level in the hierarchy If any PGs are given on the command line, only
# return sharing relationships for given PGs, but still keep them sorted.
#
sub sharing_relationships
{
	scalar @_ or _usage("sharing_relationships(cookie, [pg, ...])");

	my $self = shift;
	my @pgs = $self->all_breadth_first();

	if (scalar @_ > 0) {
		#
		# Caller specified PGs, remove any PGs not in caller's list
		#
		my %seen;
		map { $seen{$_} = 1 } @_;

		# Remove any PGs not provided by user
		@pgs = grep { $seen{$_} } @pgs;
	}

	return (_uniq(map { $self->sh_name($_) } @pgs));
}

#
# Return PG generation number. If PG is specified in the argument, return its
# generation, otherwise return snapshot generation.
# Snapshot generation is calculated as the total of PG generations
#
sub generation
{
	(scalar @_ == 1 || scalar @_ == 2) or _usage("generation(cookie, [pg])");
	my $self = shift;

	if (scalar @_ == 0) {
		my @generations = map { $_->{generation} }
				  values %{$self->{PGTREE}};
		return (sum(@generations));

	} else {
		my $id = shift;
		my $pg = _pg_get($self, $id) or return;
		return ($pg->{generation});
	}
}

#
# Return level of PG in the tree, starting from root.
# PG level is cached in the $pg->{level} field.
#
sub level
{
	scalar @_ == 2 or _usage("level(cookie, pg)");
	my $self = shift;
	my $pgid = shift;
	my $pg = _pg_get($self, $pgid) or return;

	return $pg->{level} if defined($pg->{level});

	$pg->{level} = 0;

	my $parent = _pg_get($self, $pg->{parent});
	while ($parent) {
		$pg->{level}++;
		$parent = _pg_get($self, $parent->{parent});
	}

	return ($pg->{level});
}

#
# Return T if PG supports utilization We assume that utilization is supported by
# PG if it shows any non-zero time in util_time_running. It is possible that the
# same condition may be caused by cpustat(1) running ever since PG was created,
# but there is not much we can do about it.
#
sub has_utilization
{
	scalar @_ == 2 or _usage("has_utilization(cookie, pg)");
	my $pg = _pg_get(shift, shift) or return;

	return ($pg->{util_time_running} != 0);
}


#
# Return utilization for the PG
# Utilization is a difference in utilization value between two snapshots.
# We can only compare utilization between PGs having the same generation ID.
#
sub utilization
{
	scalar @_ == 3 or _usage("utilization(cookie, cookie1, pg");
	my $c1 = shift;
	my $c2 = shift;
	my $id = shift;

	#
	# Since we have two cookies, update capacity in both
	#
	_capacity_update($c1, $c2, $id);

	my $pg1 = _pg_get($c1, $id) or return;
	my $pg2 = _pg_get($c2, $id) or return;

	#
	# Nothing to return if one of the utilizations wasn't measured
	#
	return unless ($pg1->{util_time_running} && $pg2->{util_time_running});

	#
	# Verify generation IDs
	#
	return unless $pg1->{generation} eq $pg2->{generation};
	my $u1 = $pg1->{util};
	my $u2 = $pg2->{util};
	return unless defined ($u1) && defined ($u2);

	return (abs($u2 - $u1));
}

#
# Return an estimate of PG capacity Capacity is calculated as the maximum of
# observed utilization expressed in units per second or maximum CPU frequency
# for all CPUs.
#
# We store capacity per sharing relationship, assuming that the same sharing has
# the same capacity. This may not be true for heterogeneous systems.
#
sub capacity
{
	scalar @_ == 2 or _usage("capacity(cookie, pg");
	my $self = shift;
	my $pgid = shift;
	my $pg = _pg_get($self, $pgid) or return;
	my $shname = $pg->{sh_name} or return;

	return (max($self->{MAX_FREQUENCY}, $self->{CAPACITY}->{$shname}));
}

#
# Return accuracy of utilization calculation between two snapshots The accuracy
# is determined based on the total time spent running and not running the
# counters. If T1 is the time counters were running during the period and T2 is
# the time they were turned off, the accuracy is T1 / (T1 + T2), expressed in
# percentages.
#
sub accuracy
{
	scalar @_ == 3 or _usage("accuracy(cookie, cookie1, pg)");
	my $c1 = shift;
	my $c2 = shift;
	my $id = shift;
	my $trun;
	my $tstop;

	my $pg1 = _pg_get($c1, $id) or return;
	my $pg2 = _pg_get($c2, $id) or return;

	# Both PGs should have the same generation
	return unless $pg1->{generation} eq $pg2->{generation};

	#
	# Get time spent with running and stopped counters
	#
	$trun = abs($pg2->{util_time_running} -
		    $pg1->{util_time_running});
	$tstop = abs($pg2->{util_time_stopped} -
		     $pg1->{util_time_stopped});

	my $total = $trun + $tstop;

	#
	# Calculate accuracy as percentage
	#
	my $accuracy = $total ? ($trun * 100) / $total : 0;
	$accuracy = int($accuracy + 0.5);
	$accuracy = 100 if $accuracy > 100;
	return ($accuracy);
}

#
# Return time difference in seconds between two snapshots
#
sub tdelta
{
	scalar @_ == 3 or _usage("tdelta(cookie, cookie1, pg)");
	my $c1 = shift;
	my $c2 = shift;
	my $id = shift;

	my $pg1 = _pg_get($c1, $id) or return;
	my $pg2 = _pg_get($c2, $id) or return;

	return unless $pg1->{generation} eq $pg2->{generation};

	my $t1 = $pg1->{snaptime};
	my $t2 = $pg2->{snaptime};
	my $delta = abs($t1 - $t2);
	return ($delta);
}

#
# Return software utilization between two snapshots
# In scalar context return software load as percentage.
# In list context return a list (USER, SYSTEM, IDLE, SWLOAD)
# All loads are returned as percentages
#
sub sw_utilization
{
	scalar @_ == 3 or _usage("tdelta(cookie, cookie1, pg)");

	my $c1 = shift;
	my $c2 = shift;
	my $id = shift;

	my $pg1 = _pg_get($c1, $id) or return;
	my $pg2 = _pg_get($c2, $id) or return;

	return unless $pg1->{generation} eq $pg2->{generation};

	my @cpus = $c1->cpus($id);

	my $load1 = $c1->{CPU_LOAD};
	my $load2 = $c2->{CPU_LOAD};

	my $idle = 0;
	my $user = 0;
	my $sys = 0;
	my $total = 0;
	my $swload = 0;

	foreach my $cpu (@cpus) {
		my $ld1 = $load1->{$cpu};
		my $ld2 = $load2->{$cpu};
		next unless $ld1 && $ld2;

		$idle += $ld2->{cpu_idle} - $ld1->{cpu_idle};
		$user += $ld2->{cpu_user} - $ld1->{cpu_user};
		$sys  += $ld2->{cpu_sys}  - $ld1->{cpu_sys};
	}

	$total = $idle + $user + $sys;

	# Prevent division by zero
	$total = 1 unless $total;

	$swload = ($user + $sys) * 100 / $total;
	$idle   = $idle * 100 / $total;
	$user   = $user * 100 / $total;
	$sys    = $sys  * 100 / $total;

	return (wantarray() ? ($user, $sys, $idle, $swload) : $swload);
}

#
# Return utilization for the PG for a given CPU
# Utilization is a difference in utilization value between two snapshots.
# We can only compare utilization between PGs having the same generation ID.
#
sub cpu_utilization
{
	scalar @_ == 4 or _usage("utilization(cookie, cookie1, pg, cpu");
	my $c1 = shift;
	my $c2 = shift;
	my $id = shift;
	my $cpu = shift;

	my $idle = 0;
	my $user = 0;
	my $sys = 0;
	my $swtotal = 0;
	my $swload = 0;

	#
	# Since we have two cookies, update capacity in both
	#
	_capacity_update($c1, $c2, $id);

	my $pg1 = _pg_get($c1, $id) or return;
	my $pg2 = _pg_get($c2, $id) or return;

	#
	# Nothing to return if one of the utilizations wasn't measured
	#
	return unless ($pg1->{util_time_running} && $pg2->{util_time_running});

	#
	# Nothing to return if CPU data is missing
	#
	return unless $pg1->{cpudata} && $pg2->{cpudata};

	#
	# Verify generation IDs
	#
	return unless $pg1->{generation} eq $pg2->{generation};

	#
	# Get data for the given CPU
	#
	my $cpudata1 = $pg1->{cpudata}->{$cpu};
	my $cpudata2 = $pg2->{cpudata}->{$cpu};

	return unless $cpudata1 && $cpudata2;

	return unless $cpudata1->{generation} == $cpudata2->{generation};

	my $u1 = $cpudata1->{util};
	my $u2 = $cpudata2->{util};
	return unless defined ($u1) && defined ($u2);
	my $hw_utilization = abs ($u1 - $u2);

	#
	# Get time spent with running and stopped counters
	#
	my $trun = abs($cpudata1->{util_time_running} -
		       $cpudata2->{util_time_running});
	my $tstop = abs($cpudata1->{util_time_stopped} -
			$cpudata2->{util_time_stopped});

	my $total = $trun + $tstop;

	#
	# Calculate accuracy as percentage
	#
	my $accuracy = $total ? ($trun * 100) / $total : 0;
	$accuracy = int($accuracy + 0.5);
	$accuracy = 100 if $accuracy > 100;

	my $t1 = $cpudata1->{snaptime};
	my $t2 = $cpudata2->{snaptime};
	my $tdelta = abs ($t1 - $t2);

	my $shname = $pg2->{sh_name} or return;
	my $capacity = max($c2->{MAX_FREQUENCY}, $c2->{CAPACITY}->{$shname});
	my $utilization = $hw_utilization / $tdelta;
	$capacity = $utilization unless $capacity;
	$utilization /= $capacity;
	$utilization *= 100;

	my $ld1 = $c1->{CPU_LOAD}->{$cpu};
	my $ld2 = $c2->{CPU_LOAD}->{$cpu};

	if ($ld1 && $ld2) {
		$idle = $ld2->{cpu_idle} - $ld1->{cpu_idle};
		$user = $ld2->{cpu_user} - $ld1->{cpu_user};
		$sys  = $ld2->{cpu_sys}  - $ld1->{cpu_sys};

		$swtotal = $idle + $user + $sys;

		# Prevent division by zero
		$swtotal = 1 unless $swtotal;

		$swload = ($user + $sys) * 100 / $swtotal;
		$idle   = $idle * 100 / $swtotal;
		$user   = $user * 100 / $swtotal;
		$sys    = $sys  * 100 / $swtotal;
	}

	return (wantarray() ?
		($utilization, $accuracy, $hw_utilization,
		 $swload, $user, $sys, $idle) :
		$utilization);
}

#
# online_cpus(kstat)
# Return list of on-line CPUs
#
sub online_cpus
{
	scalar @_ == 1 or _usage("online_cpus(cookie)");

	my $self = shift or return;
	my $ks = $self->{KSTAT} or return;

	my $cpu_info = $ks->{cpu_info} or return;

	my @cpus = grep {
		my $cp = $cpu_info->{$_}->{"cpu_info$_"};
		my $state = $cp->{state};
		$state eq 'on-line' || $state eq 'no-intr';
	} keys %{$cpu_info};

	return (wantarray() ? @cpus : _nsort(@cpus));
}

#
# Support methods
#
# The following methods are not PG specific but are generally useful for PG
# interface consumers
#

#
# Sort the list numerically
#
sub nsort
{
	scalar @_ > 0 or _usage("nsort(cookie, val, ...)");
	shift;

	return (_nsort(@_));
}

#
# Return the input list with duplicates removed.
# Should be used in list context
#
sub uniq
{
	scalar @_ > 0 or _usage("uniq(cookie, val, ...)");
	shift;

	return (_uniq(@_));
}

#
# Sort list numerically and remove duplicates
# Should be called in list context
#
sub uniqsort
{
	scalar @_ > 0 or _usage("uniqsort(cookie, val, ...)");
	shift;

	return (_uniqsort(@_));
}


#
# Expand all arguments and present them as a numerically sorted list
# x,y is expanded as (x y)
# 1-3 ranges are expandes as (1 2 3)
#
sub expand
{
	scalar @_ > 0 or _usage("expand(cookie, val, ...)");
	shift;

	return (_uniqsort(map { _expand($_) } @_));
}

#
# Consolidate consecutive ids as start-end
# Input: list of ids
# Output: string with space-sepated cpu values with ranges
#   collapsed as x-y
#
sub id_collapse
{
	scalar @_ > 0 or _usage("collapse(cookie, val, ...)");
	shift;

	return _collapse(@_);
}

#
# Return elements of the second list not present in the first list. Both lists
# are passed by reference.
#
sub set_subtract
{
	scalar @_ == 3 or _usage("set_subtract(cookie, left, right)");
	shift;

	return (_set_subtract(@_));
}

#
# Return the intersection of two lists passed by reference
# Convert the first list to a hash with seen entries marked as 1-values
# Then grep only elements present in the first list from the second list.
# As a little optimization, use the shorter list to build a hash.
#
sub intersect
{
	scalar @_ == 3 or _usage("intersect(cookie, left, right)");
	shift;

	return (_set_intersect(@_));
}

#
# Return elements of the second list not present in the first list. Both lists
# are passed by reference.
#
sub _set_subtract
{
	my ($left, $right) = @_;
	my %seen;	# Set to 1 for everything in the first list
	# Create a hash indexed by elements in @left with ones as a value.
	map { $seen{$_} = 1 } @$left;
	# Find members of @right present in @left
	return (grep { ! $seen{$_} } @$right);
}

#
# END OF PUBLIC INTERFACE
#

#
# INTERNAL FUNCTIONS
#

#
# _usage(): print error message and terminate the program.
#
sub _usage
{
	my $msg = shift;
	Carp::croak "Usage: Sun::Solaris::Pg::$msg";
}

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

#
# Return the input list with duplicates removed.
# Should be used in list context
#
sub _uniq
{
	my %seen;
	return (grep { ++$seen{$_} == 1 } @_);
}

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

# Get PG from the snapshot by id
sub _pg_get
{
	my $self = shift;
	my $pgid = shift;

	return unless defined $pgid;
	my $pgtree = $self->{PGTREE} or return;

	return ($pgtree->{$pgid});
}

#
# Copy data from kstat representation to our representation
# Arguments:
#   PG kstat
#   Reference to the list of CPUs.
# Any CPUs in the PG kstat not present in the CPU list are ignored.
#
sub _pg_create_from_kstat
{
	my $pg_ks = shift;
	my $all_cpus = shift;
	my %all_cpus;
	my $pg = ();

	#
	# Mark CPUs available
	#
	map { $all_cpus{$_}++ } @$all_cpus;

	return unless $pg_ks;

	#
	# Convert CPU list in the kstat from x-y,z form to the proper list
	#
	my @cpus = _expand($pg_ks->{cpus});

	#
	# Remove any CPUs not present in the arguments
	#
	@cpus = grep { $all_cpus{$_} } @cpus;

	#
	# Do not create PG unless it has any CPUs
	#
	return unless scalar @cpus;

	#
	# Copy data to the $pg structure
	#
	$pg->{ncpus} = scalar @cpus;
	$pg->{cpus} = \@cpus;
	$pg->{id} = defined($pg_ks->{pg_id}) ? $pg_ks->{pg_id} : $pg_ks->{id};
	$pg->{util} = $pg_ks->{hw_util};
	$pg->{current_rate} = $pg_ks->{hw_util_rate};
	$pg->{util_rate_max} = $pg_ks->{hw_util_rate_max};
	$pg->{util_time_running} = $pg_ks->{hw_util_time_running};
	$pg->{util_time_stopped} = $pg_ks->{hw_util_time_stopped};
	$pg->{snaptime} = $pg_ks->{snaptime};
	$pg->{generation} = $pg_ks->{generation};
	$pg->{sh_name} = $pg_ks->{relationship} || $pg_ks->{sharing_relation};
	$pg->{parent} = $pg_ks->{parent_pg_id};
	$pg->{parent} = PG_PARENT_UNDEF unless defined $pg->{parent};
	#
	# Replace spaces with underscores in sharing names
	#
	$pg->{sh_name} =~ s/ /_/g;
	$pg->{is_leaf} = 1;

	return $pg;
}

#
# Create fake root PG with all CPUs
# Arguments: list of CPUs
#
sub _pg_create_root
{
	my $pg = ();
	my @cpus = @_;

	$pg->{id} = $ROOT_ID;
	$pg->{ncpus} = scalar @cpus;
	$pg->{util} = 0;
	$pg->{current_rate} = 0;
	$pg->{util_rate_max} = 0;
	$pg->{util_time_running} = 0;
	$pg->{util_time_stopped} = 0;
	$pg->{snaptime} = 0;
	$pg->{generation} = 0;
	$pg->{sh_name} = 'System';
	$pg->{is_leaf} = 0;
	$pg->{cpus} = \@cpus;
	$pg->{parent} = PG_NO_PARENT;

	return ($pg);
}

#
# _pg_all_from_kstats(SNAPSHOT)
# Extract all PG information from kstats
#
sub _pg_all_from_kstats
{
	my $self = shift;
	my $ks = $self->{KSTAT};
	my @all_cpus = @{$self->{CPUS}};

	return unless $ks;

	my $pgtree = ();
	my $pg_info = $ks->{$self->{PG_MODULE}};

	#
	# Walk all PG kstats and copy them to $pgtree->{$id}
	#
	foreach my $id (keys %$pg_info) {
		my $pg_ks = _kstat_get_pg($pg_info, $id,
					  $self->{USE_OLD_KSTATS});
		next unless $pg_ks;

		my $pg = _pg_create_from_kstat($pg_ks, \@all_cpus);

		$pgtree->{$id} = $pg if $pg;
	}

	#
	# OS does not have root PG, so create one.
	#
	if (!$pgtree->{$ROOT_ID}) {
		$pgtree->{$ROOT_ID} = _pg_create_root (@all_cpus);
	}

	#
	# Construct parent-child relationships between PGs
	#

	#
	# Get list of PGs sorted by number of CPUs
	# If two PGs have the same number of CPUs, sort by relationship order.
	#
	my @lineage = sort {
		$a->{ncpus} <=> $b->{ncpus} ||
		_relationship_order($a->{sh_name}) <=>
		_relationship_order($b->{sh_name})
	    } values %$pgtree;

	#
	# For each PG in the lineage discover its parent if it doesn't have one.
	#
	for (my $i = 0; $i < scalar @lineage; $i++) {
		my $pg = $lineage[$i];

		#
		# Ignore PGs which already have parent in kstats
		#
		my $parent = $pg->{parent};
		next if ($parent >= PG_NO_PARENT);

		my $ncpus = $pg->{ncpus};
		my @cpus = @{$pg->{cpus}};

		#
		# Walk the lineage, ignoring any CPUs with the same number of
		# CPUs
		for (my $j = $i + 1; $j < scalar @lineage; $j++) {
			my $pg1 = $lineage[$j];
			my @parent_cpus = @{$pg1->{cpus}};
			if (_is_subset(\@cpus, \@parent_cpus)) {
				$pg->{parent} = $pg1->{id};
				last;
			}
		}
	}

	#
	# Find all top-level PGs and put them under $root
	#
	foreach my $pgid (keys %$pgtree) {
		next if $pgid == $ROOT_ID;
		my $pg = $pgtree->{$pgid};
		$pg->{parent} = $ROOT_ID unless $pg->{parent} >= 0;
	}

	#
	# Now that we know parents, for each parent add all direct children to
	# their parent sets
	#
	foreach my $pg (@lineage) {
		my $parentid = $pg->{parent};
		next unless defined $parentid;

		my $parent = $pgtree->{$parentid};
		push (@{$parent->{children}}, $pg->{id});
	}

	return ($pgtree);
}

#
# Read kstats and initialize PG object
# Collect basic information about cmt_pg
# Add list of children and list of CPUs
# Returns the hash reference indexed by pg id
#
# The _init() function accepts arguments in the form of a hash. The following
# subarguments are supported:
#
#   -cpudata	# Collect per-CPU data from kstats if this is T
#   -tags	# Match PGs to physical relationships if this is T
#   -swload	# Collect software CPU load if this is T

sub _init
{
	my $ks = Sun::Solaris::Kstat->new(strip_strings => 1);
	return unless $ks;

	my %args = @_;
	my $get_cpu_data = $args{-cpudata};
	my $get_tags = $args{-tags};
	my $get_swload = $args{-swload};

	my $self;

	my $use_old_kstat_names = scalar(grep {/^pg_hw_perf/ } keys (%$ks)) == 0;

	my @frequencies;
	$self->{MAX_FREQUENCY} = 0;

	$self->{PG_MODULE} = $use_old_kstat_names ? 'pg' : 'pg_hw_perf';
	$self->{PG_CPU_MODULE} =  $use_old_kstat_names ?
	  'pg_cpu' : 'pg_hw_perf_cpu';
	$self->{USE_OLD_KSTATS} = $use_old_kstat_names;

	$get_cpu_data = 0 unless  scalar(grep {/^$self->{PG_CPU_MODULE}/ }
					 keys (%$ks));

	# Get list of PG-related kstats
	my $pg_keys = $use_old_kstat_names ? 'pg' : 'pg_hw';

	if (scalar(grep { /^$pg_keys/ } keys (%$ks)) == 0) {
		if (exists(&Errno::ENOTSUPP)) {
			$! = &Errno::ENOTSUPP;
		} else {
			$! = 48;
		}
		return;
	}


	#
	# Mapping of cores and chips to CPUs
	#
	my $hw_mapping;

	#
	# Get list of all CPUs
	#
	my $cpu_info = $ks->{cpu_info};

	#
	# @all-cpus is a list of all cpus
	#
	my @all_cpus = keys %$cpu_info;

	#
	# Save list of all CPUs in the snapshot
	#
	$self->{CPUS} = \@all_cpus;

	#
	# Find CPUs for each socket and chip
	# Also while we scan CPU kstats, get maximum frequency of each CPU.
	#
	foreach my $id (@all_cpus) {
		my $ci = $cpu_info->{$id}->{"cpu_info$id"};
		next unless $ci;
		my $core_id = $ci->{core_id};
		my $chip_id = $ci->{chip_id};

		push(@{$hw_mapping->{core}->{$core_id}}, $id)
		  if defined $core_id;
		push(@{$hw_mapping->{chip}->{$chip_id}}, $id)
		  if defined $chip_id;

		# Read CPU frequencies separated by commas
		my $freqs = $ci->{supported_frequencies_Hz};
		my $max_freq = max(split(/:/, $freqs));

		# Calculate maximum frequency for the snapshot.
		$self->{MAX_FREQUENCY} = $max_freq if
		  $self->{MAX_FREQUENCY} < $max_freq;
	}

	$self->{KSTAT} = $ks;

	#
	# Convert kstats to PG tree
	#
	my $pgtree = _pg_all_from_kstats($self);
	$self->{PGTREE} = $pgtree;

	#
	# Find capacity estimate per sharing relationship
	#
	foreach my $pgid (keys %$pgtree) {
		my $pg = $pgtree->{$pgid};
		my $shname = $pg->{sh_name};
		my $max_rate = $pg->{util_rate_max};
		$self->{CAPACITY}->{$shname} = $max_rate if
		  !$self->{CAPACITY}->{$shname} ||
		    $self->{CAPACITY}->{$shname} < $max_rate;
	}

	if ($get_tags) {
		#
		# Walk all PGs and mark all PGs that have corresponding hardware
		# entities (system, chips, cores).
		#
		foreach my $pgid (keys %$pgtree) {
			my $pg = $pgtree->{$pgid};
			my @cpus = @{$pg->{cpus}};
			next unless scalar @cpus > 1;

			if (_set_equal (\@cpus, \@all_cpus)) {
				#
				# PG has all CPUs in the system.
				#
				push (@{$pg->{tags}}, 'system');
			}

			foreach my $name ('core', 'chip') {
				my $hwdata = $hw_mapping->{$name};
				foreach my $id (keys %$hwdata) {
					# CPUs for this entity
					my @hw_cpus = @{$hwdata->{$id}};
					if (_set_equal (\@cpus, \@hw_cpus)) {
						#
						# PG has exactly the same CPUs
						#
						push (@{$pg->{tags}}, $name);
					}
				}
			}
		}
	}

	#
	# Save software load for each CPU
	#
	if ($get_swload) {
		$self->{CPU_LOAD} = _get_sw_cpu_load($ks);
	}

	#
	# Collect per-CPU utilization data if requested
	#
	if ($get_cpu_data) {
		_get_hw_cpu_load($self);
	}

	$self->{GET_CPU_DATA} = $get_cpu_data;

	#
	# Verify that in the end we have the same PG generation for each PG
	#
	if (! _same_generation($self)) {
		$! = &Errno::EAGAIN;
		return;
	}

	return ($self);
}

#
# Verify that topology is the same as at the time snapshot was created
#
sub _same_generation
{
	my $self = shift;
	my $pgtree =  $self->{PGTREE} or return;

	return (0) unless $self;

	my $ks = $self->{KSTAT};
	$ks->update();
	my $pg_info = $ks->{$self->{PG_MODULE}};
	foreach my $id (keys %$pg_info) {
		my $pg = $pgtree->{$id} or next;

		my $pg_ks = _kstat_get_pg($pg_info, $id,
					  $self->{USE_OLD_KSTATS});
		return unless $pg_ks;
		return (0) unless $pg->{generation} == $pg_ks->{generation};
	}
	return (1);
}

#
# Update capacity for both PGs
#
sub _capacity_update
{
	my $c1 = shift;
	my $c2 = shift;

	my $pgtree1 = $c1->{PGTREE};
	my $pgtree2 = $c2->{PGTREE};

	foreach my $pgid (keys %$pgtree1) {
		my $pg1 = $pgtree1->{$pgid};
		my $pg2 = $pgtree2->{$pgid};
		next unless $pg1 && $pg2;
		next unless $pg1->{generation} != $pg2->{generation};
		my $shname1 = $pg1->{sh_name};
		my $shname2 = $pg2->{sh_name};
		next unless $shname1 eq $shname2;
		my $max_rate = max($pg1->{util_rate_max}, $pg2->{util_rate_max});

		my $utilization = abs($pg1->{util} - $pg2->{util});
		my $tdelta = abs($pg1->{snaptime} - $pg2->{snaptime});
		$utilization /= $tdelta if $utilization && $tdelta;
		$max_rate = $utilization if
		  $utilization && $max_rate < $utilization;

		$c1->{CAPACITY}->{$shname1} = $max_rate if
		  !$c1->{CAPACITY}->{$shname1} ||
		    !$c1->{CAPACITY}->{$shname1} < $max_rate;
		$c2->{CAPACITY}->{$shname2} = $max_rate if
		  !$c2->{CAPACITY}->{$shname2} ||
		    !$c2->{CAPACITY}->{$shname2} < $max_rate;
	}
}

#
# Return list of PGs breadth first
#
sub _walk_depth_first
{
	my $p = shift;
	# Nothing to do if list is empty
	return unless scalar (@_);

	return (map { ($_, _walk_depth_first ($p, $p->children($_))) } @_);
}

#
# Return list of PGs breadth first
#
sub _walk_breadth_first
{
	my $p = shift;
	# Nothing to do if list is empty
	return unless scalar (@_);

	return (@_, _walk_breadth_first($p, map { $p->children($_) } @_));
}

#
# Given the kstat reference (already hashed by module name) and PG ID return the
# corresponding kstat.
#
sub _kstat_get_pg
{
	my $mod = shift;
	my $pgid = shift;
	my $use_old_kstats = shift;

	my $id_field = $use_old_kstats ? 'id' : 'pg_id';

	return ($mod->{$pgid}->{hardware}) if $use_old_kstats;

	my @instances = grep { $_->{$id_field} == $pgid }
	  values(%{$mod->{$pgid}});
	return ($instances[0]);
}

######################################################################
# Set routines
#######################################################################
#
# Return T if one list contains all the elements of another list.
# All lists are passed by reference
#
sub _is_subset
{
	my ($left, $right) = @_;
	my %seen;	# Set to 1 for everything in the first list
	# Put the shortest list in $left

	Carp::croak "invalid left argument" unless ref ($left) eq 'ARRAY';
	Carp::croak "invalid right argument" unless ref ($right) eq 'ARRAY';

	# Create a hash indexed by elements in @right with ones as a value.
	map { $seen{$_} = 1 } @$right;

	# Find members of @left not present in @right
	my @extra = grep { !$seen{$_} } @$left;
	return (!scalar(@extra));
}

sub _is_member
{
	my $set = shift;
	my $element = shift;
	my %seen;

	map { $seen{$_} = 1 } @$set;

	return ($seen{$element});
}

#
# Return T if C1 and C2 contain the same elements
#
sub _set_equal
{
	my $c1 = shift;
	my $c2 = shift;

	return 0 unless scalar @$c1 == scalar @$c2;

	return (_is_subset($c1, $c2) && _is_subset($c2, $c1));
}

#
# Return the intersection of two lists passed by reference
# Convert the first list to a hash with seen entries marked as 1-values
# Then grep only elements present in the first list from the second list.
# As a little optimization, use the shorter list to build a hash.
#
sub _set_intersect
{
	my ($left, $right) = @_;
	my %seen;	# Set to 1 for everything in the first list
	# Put the shortest list in $left
	scalar @$left <= scalar @$right or ($right, $left) = ($left, $right);

	# Create a hash indexed by elements in @left with ones as a value.
	map { $seen{$_} = 1 } @$left;
	# Find members of @right present in @left
	return (grep { $seen{$_} } @$right);
}

#
# Expand start-end into the list of values
# Input: string containing a single numeric ID or x-y range
# Output: single value or a list of values
# Ranges with start being more than end are inverted
#
sub _expand
{
	# Skip the first argument if it is the object reference
	shift if ref $@[0] eq 'HASH';

	my $arg = shift;

	return unless defined $arg;

	my @args = split /,/, $arg;

	return map { _expand($_) } @args if scalar @args > 1;

	$arg = shift @args;
	return unless defined $arg;

	if ($arg =~ m/^\d+$/) {
		# single number
		return ($arg);
	} elsif ($arg =~ m/^(\d+)\-(\d+)$/) {
		my ($start, $end) = ($1, $2);	# $start-$end
		# Reverse the interval if start > end
		($start, $end) = ($end, $start) if $start > $end;
		return ($start .. $end);
	} else {
		return $arg;
	}
	return;
}

#
# Consolidate consecutive ids as start-end
# Input: list of ids
# Output: string with space-sepated cpu values with ranges
#   collapsed as x-y
#
sub _collapse
{
	return ('') unless @_;
	my @args = _uniqsort(@_);
	my $start = shift(@args);
	my $result = '';
	my $end = $start;	# Initial range consists of the first element
	foreach my $el (@args) {
		if (!$el =~ /^\d+$/) {
			$result = "$result $el";
			$end = $el;
		} elsif ($el == ($end + 1)) {
			#
			# Got consecutive ID, so extend end of range without
			# printing anything since the range may extend further
			#
			$end = $el;
		} else {
			#
			# Next ID is not consecutive, so print IDs gotten so
			# far.
			#
			if ($end > $start + 1) {	# range
				$result = "$result $start-$end";
			} elsif ($end > $start) {	# different values
				$result = "$result $start $end";
			} else {	# same value
				$result = "$result $start";
			}

			# Try finding consecutive range starting from this ID
			$start = $end = $el;
		}
	}

	# Print last ID(s)
	if (! ($end =~ /^\d+$/)) {
		$result = "$result $end";
	} elsif ($end > $start + 1) {
		$result = "$result $start-$end";
	} elsif ($end > $start) {
		$result = "$result $start $end";
	} else {
		$result = "$result $start";
	}
	# Remove any spaces in the beginning
	$result =~ s/^\s+//;
	return ($result);
}

#
# get relationship order from relationship name.
# return 0 for all unknown names.
#
sub _relationship_order
{
	my $name = shift;
	return ($relationships_order{$name} || 0);
}

#
# Get software load for each CPU from kstats
# Argument: kstat reference
# Returns: reference to the hash with 
# cpu_idle, cpu_user, cpu_sys keys.
#
sub _get_sw_cpu_load
{
	my $ks = shift or return;

	my $loads;
	my $sys_ks = $ks->{cpu};
	foreach my $cpu (keys %$sys_ks) {
		my $sys = $sys_ks->{$cpu}->{sys};
		$loads->{$cpu}->{cpu_idle} = $sys->{cpu_ticks_idle};
		$loads->{$cpu}->{cpu_user} = $sys->{cpu_ticks_user};
		$loads->{$cpu}->{cpu_sys} = $sys->{cpu_ticks_kernel};
	}

	return ($loads);
}

#
# Get software load for each CPU from kstats
# Arguments:
#  pgtree reference
#  kstat reference
#
# Returns: nothing
# Stores CPU load in the $pg->{cpudata} hash for each PG
#
sub _get_hw_cpu_load
{
	my $self = shift;
	my $pgtree = $self->{PGTREE};
	my $ks = $self->{KSTAT};

	my $pg_cpu_ks = $ks->{$self->{PG_CPU_MODULE}};

	foreach my $pgid (keys %$pgtree) {
		my $pg = $pgtree->{$pgid};
		my @cpus = @{$pg->{cpus}};
		my $cpu;
		my $pg_id;
		foreach my $cpu (keys %$pg_cpu_ks) {
			next unless _is_member(\@cpus, $cpu);
			my $cpu_hw_data = $pg_cpu_ks->{$cpu};
			foreach my $hw (keys %$cpu_hw_data) {
				my $cpudata = $cpu_hw_data->{$hw};

				#
				# Only consider information for this PG
				#
				next unless $cpudata->{pg_id} == $pgid;

				$pg->{cpudata}->{$cpu}->{generation} =
				  $cpudata->{generation};
				$pg->{cpudata}->{$cpu}->{util} =
				  $cpudata->{hw_util};
				$pg->{cpudata}->{$cpu}->{util_time_running} =
				  $cpudata->{hw_util_time_running};
				$pg->{cpudata}->{$cpu}->{util_time_stopped} =
				  $cpudata->{hw_util_time_stopped};
				$pg->{cpudata}->{$cpu}->{snaptime} =
				  $cpudata->{snaptime};
			}
		}
	}
}

1;

__END__

#
# The information about PG hierarchy is contained in a object return by the
# new() method.
#
# This module can deal with old PG kstats that have 'pg' and 'pg_cpu' as module
# names as well as new PG kstats which use 'pg_hw_perf' and ''pg_hw_perf_cpu' as
# the module name.
#
# The object contains the following fields:
#
#   CPUS		List of all CPUs present.
#   CAPACITY		Estimate of capacity for each sharing
#   PGTREE		The PG tree. See below for the tree representation.
#
#   PG_MODULE 		Module name for the PG kstats. It is either 'pg' for
#			 old style kstats, or 'pg_hw_perf' for new style kstats.
#
#   MAX_FREQUENCY	Maximum CPU frequency
#   USE_OLD_KSTATS	True if we are dealing with old style kstats
#   KSTAT		The kstat object used to generate this hierarchy.
#
# The PG tree is represented as a hash table indexed by PG ID. Each element of
# the table is the hash reference with the following fields:
#
#   children		Reference to the list of children PG IDs
#   cpus		Reference to the list of cpu IDs in the PG
#   current_rate	Current utilization rate
#   generation		PG generation
#   id			PG id
#   ncpus		number of CPUs in the PG
#   parent		PG parent id, or -1 if there is none.
#   sh_name		Sharing name
#   snaptime		Snapshot time
#   util		Hardware utilization
#   util_rate_max	Maximum utilization rate
#   util_time_running	Time (in nanoseconds) when utilization data is collected
#   util_time_stopped	Time when utilization data is not collected
#
# The fields (with the exception of 'children') are a copy of the data from
# kstats.
#
# The PG hierarchy in the kernel does not have the root PG. We simulate the root
# (System) PG which is the parent of top level PGs in the system. This PG always
# has ID 0.
#
#
# 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 (c) 2010, Oracle and/or its affiliates. All rights reserved.
#

#
# Sun::Solaris::Pg documentation
#

=head1 NAME

Solaris::Pg - Perl interface to Processor Group kstats

=head1 SYNOPSYS

  use Solaris::Pg;

  $p = Solaris::Pg->new(-cpudata=> 1, -tags=> 1, -swload=> 1);

  @pgs = $p->all();

  @pgs_depth = $p->all_depth_first();

  @pgs_breadth = $p->all_breadth_first();

  @leaves = $p->leaves();

  $root = $p->root;

  $p->update();

  $leaf = $leaves[0];

  $name = $p->sh_name($leaf);

  @names = $p->sharing_relationships();

  @tags = $p->tags($leaf);

  $p1 = Solaris::Pg->new(-cpudata=> 1, -tags=> 1, -swload=> 1);

  if ($p->has_utilization()) {
    $utilization = $p->utilization($p1, $leaf);
    $capacity = $p->capacity($p1, $leaf);
    $accuracy = $p->accuracy($p1, $leaf);
    $tdelta = $p->tdelta($p1);
  }

  $sw_utilization = $p->sw_utilization($p1, $leaf);)


=head1 DESCRIPTION

The Solaris::Pg module provides an interface to the Solaris PG information
available through B<pg> and B<pg_cpu> kstats. The module provides an object
oriented interface.

=head1 METHODS

=head2 new

Create a new Pg instance. The new() function accepts arguments in the form of a
hash. The following subarguments are supported:

=over

=item -cpudata

Collect per-CPU data from kstats if this is True.

=item  -tags

Match PGs to physical relationships if this is True.

=item  -swload

Collect software CPU load if this is True.

=back

=head2 root

Return ID of the root of Processor Group hierarchy.

=head2 all

Return list of all PGs sorted by ID.

=head2 all_depth_first()

Return list of all PGs sorted by walking the PG hierarchy depth first, starting
from root.

=head2 all_breadth_first()

Return list of all PGs sorted by walking the PG hierarchy breadth first,
starting from root.

=head2 cpus(PG)

Return list of all CPUs in the PG specified. The list is sorted by CPU ID.

=head2 generation([PG])

Return the generation number for the given PG. Without arguments, return the
generation number for the whole snapshot. Different generation number means that
PG configuration may have changed.

=head2 parent(PG)

Return parent ID or undef if there is no parent.

=head2 children(PG)

Return list of children for the PG.

=head2 is_leaf(PG)

Returns T iff PG is leaf.

=head2 leaves

Returns list of leaf PGs.

=head2 level(PG)

Return the numeric level of PG in the hierarchy, starting from root which has
level zero.

=head2 sh_name(PG)

Returns sharing name for the PG.

=head2  sharing_relationships([PG], ...)

Without any arguments, returns the list of sharing relationships in the
snapshot. Relationships are sorted by the level in the hierarchy If any PGs are
given on the command line, only return sharing relationships for given PGs, but
still keep them sorted.

=head2 tags(PG)

Return list of strings describing physical relationships ('core', 'chip') for the given PG.

=head2 update()

Update utilization and generation data in the PG snapshot.

=head2 has_utilization(PG)

Returns True if given PG hasd data about hardware utilization.

=head2 utilization(PGOBJ, PG)

Return numeric utilization for the time interval represented by two PG objects
for the given PG. Utilization is a difference in utilization value between two
snapshots. The given PG must belong to the same generation in both snapshots.
Returns B<undef> if utilization can not be obtained.

=head2 sw_utilization(PGOBJ, PG)

Return numeric software utilization for the time interval represented by two PG
objects for the given PG. Utilization is a difference in utilization value
between two snapshots. The given PG must belong to the same generation in both
snapshots. Returns B<undef> if utilization can not be obtained. Software
utilization is combined CPU load for all CPUs in the PG. Returns B<undef> if
utilization can not be obtained.

=head2 sw_utilization(PGOBJ, PG, CPU)

Return utilization for the PG for a given CPU in a given PG. Utilization is a
difference in utilization value between two snapshots. We can only compare
utilization between PGs having the same generation ID. Returns B<undef> if
utilization can not be obtained.

=head2 capacity(PGOBJ, PG)

Return numeric capacity for the time interval represented by two PG objects for
the given PG. Note that the actual capacity is the maximum of all capacities
across all PGs of this type.The given PG must belong to the same generation in
both snapshots. Returns B<undef> if capacities can not be obtained.

=head2 accuracy(PGOBJ, PG)

Return accuracy of utilization calculation between two snapshots The accuracy is
determined based on the total time spent running and not running the counters.
If T1 is the time counters were running during the period and T2 is the time
they were turned off, the accuracy is T1 / (T1 + T2), expressed in percentages.

=head2 tdelta(PGOBJ, PG)

Return time interval between two snapshots for the given PG. The time is expressed in seconds and is a floating-point number.

=head2 EXPORT

None by default.

=head1 SEE ALSO

L<pginfo(1)>, L<pgstat(1)>

=cut

#
# Copyright (c) 2003, Oracle and/or its affiliates. All rights reserved.
#

Version 1.5
Initial Public Source release.
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

include $(SRC)/Makefile.master

SUBDIRS = $(MACH64)

all :		TARGET = all
install :	TARGET = install
clean :	TARGET = clean
clobber :	TARGET = clobber

all install clean clobber: $(SUBDIRS)

$(SUBDIRS): FRC
	@cd $@; pwd; $(MAKE) $(TARGET)

FRC:
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = Project

include $(SRC)/cmd/perl/Makefile.perl

LDLIBS += -lproject -lgen

CERRWARN += -Wno-unused-variable

XSUBPPFLAGS = -typemap typemap

MAPFILES = ../mapfile-vers
#
# Copyright (c) 1999, 2008, Oracle and/or its affiliates. All rights reserved.
# Copyright (c) 2014 Racktop Systems.
#

#
# Project.pm provides the bootstrap for the Sun::Solaris::Project module, and
# also functions for reading, validating and writing out project(5) format
# files.
#
################################################################################
require 5.0010;

use strict;
use warnings;
use locale;
use Errno;
use Fcntl;
use File::Basename;
use POSIX qw(locale_h limits_h);

package Sun::Solaris::Project;

our $VERSION = '1.9';

use XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);

our (@EXPORT_OK, %EXPORT_TAGS);
my @constants = qw(MAXPROJID PROJNAME_MAX PROJF_PATH PROJECT_BUFSZ
    SETPROJ_ERR_TASK SETPROJ_ERR_POOL);
my @syscalls = qw(getprojid);
my @libcalls = qw(setproject activeprojects getprojent setprojent endprojent
    getprojbyname getprojbyid getdefaultproj fgetprojent inproj
    getprojidbyname);
my @private = qw(projf_read projf_write projf_validate projent_parse
		 projent_parse_name projent_validate_unique_name
		 projent_parse_projid projent_validate_unique_id
		 projent_parse_comment
		 projent_parse_users
		 projent_parse_groups
		 projent_parse_attributes
		 projent_validate projent_validate_projid
		 projent_values_equal projent_values2string);

@EXPORT_OK = (@constants, @syscalls, @libcalls, @private);
%EXPORT_TAGS = (CONSTANTS => \@constants, SYSCALLS => \@syscalls,
    LIBCALLS => \@libcalls, PRIVATE => \@private, ALL => \@EXPORT_OK);

use base qw(Exporter);
use Sun::Solaris::Utils qw(gettext);

#
# Set up default rules for validating rctls.
# These rules are not global-flag specific, but instead
# are the total set of allowable values on all rctls.
#
use Config;
our $MaxNum = &RCTL_MAX_VALUE;
our %RctlRules;

my %rules;
our %SigNo;
my $j;
my $name;
foreach $name (split(' ', $Config{sig_name})) {
	$SigNo{$name} = $j;
	$j++;
}
%rules = (
    'privs' 	=> [ qw(basic privileged priv) ],
    'actions'	=> [ qw(none deny sig) ],
    'signals'	=> [ qw(ABRT XRES HUP STOP TERM KILL XFSZ XCPU),
		     $SigNo{'ABRT'},
		     $SigNo{'XRES'},
		     $SigNo{'HUP'},
		     $SigNo{'STOP'},
		     $SigNo{'TERM'},
		     $SigNo{'KILL'},
		     $SigNo{'XFSZ'},
		     $SigNo{'XCPU'} ],
    'max'	=> $MaxNum
);
	       
$RctlRules{'__DEFAULT__'} = \%rules;

#
# projf_combine_errors(errorA, errorlistB)
#
# Concatenates a single error with a list of errors.  Each error in the new
# list will have a status matching the status of errorA.
#
# Example:
# 
#	projf_combine_errors(
#	    [ 5, "Error on line %d, 10 ],
#	    [ [ 3, "Invalid Value %s", "foo" ],
#	      [ 6, "Duplicate Value %s", "bar" ]
#	    ]);
#
# would return the list ref:
#
#	[ [ 5, "Error on line %d: Invalid Value %s", 10, "foo" ],
#	  [ 5, "Error on line %d: Duplicate Value %s", 10, "bar" ]
#	]
#
# This function is used when a fuction wants to add more information to
# a list of errors returned by another function.
#
sub projf_combine_errors
{

	my ($error1, $errorlist)  = @_;
	my $error2;

	my $newerror;
	my @newerrorlist;

	my ($err1, $fmt1, @args1);
	my ($err2, $fmt2, @args2);

	($err1, $fmt1, @args1) = @$error1;
	foreach $error2 (@$errorlist) {

		($err2, $fmt2, @args2) = @$error2;
		$newerror = [ $err1, $fmt1 . ', ' . $fmt2, @args1, @args2];
		push(@newerrorlist, $newerror);
	}
	return (\@newerrorlist);
}

#
# projf_read(filename, flags)
#
# Reads and parses a project(5) file, and returns a list of projent hashes.
#
# Inputs:
#	filename - file to read
#	flags	 - hash ref of flags
#
# If flags contains key "validate", the project file entries will also be
# validated for run-time correctness  If so, the flags ref is forwarded to
# projf_validate().
#
# Return Value:
#
# Returns a ref to a list of projent hashes.  See projent_parse() for a
# description of a projent hash.
#
sub projf_read
{

	my ($fh, $flags) = @_;
	my @projents;
	my $projent;
	my $linenum = 0;
	my ($projname, $projid, $comment, $users, $groups, $attributes);
	my ($ret, $ref);
	my @errs;

	my ($line, $origline, $next, @projf);
	while (defined($line = <$fh>)) {

		$linenum++;
		$origline = $line;

		# Remove any line continuations and trailing newline.
		$line =~ s/\\\n//g;
		chomp($line);


		if (length($line) > (&PROJECT_BUFSZ - 2)) {
			push(@errs, 
			    [5,
			      gettext('Parse error on line %d, line too long'),
			    $linenum]);

		}

		($ret, $ref) = projent_parse($line, {});
		if ($ret != 0) {
			$ref = projf_combine_errors(
			    [5, gettext('Parse error on line %d'), $linenum],
			    $ref);
			push(@errs, @$ref);
			next;
		}

		$projent = $ref;

		#
		# Cache original line to save original format if it is
		# not changed.
		#
		$projent->{'line'} = $origline;
		$projent->{'modified'} = 'false';
		$projent->{'linenum'} = $linenum;

		push(@projents, $projent);
	}

	if (defined($flags->{'validate'}) && ($flags->{'validate'} eq 'true')) {
		($ret, $ref) = projf_validate(\@projents, $flags);
		if ($ret != 0) {
			push(@errs, @$ref);
		}	
	}	

	if (@errs) {
		return (1, \@errs);
		
	} else {
		return (0, \@projents);
	}
}	

#
# projf_write(filehandle, projent list)
# 
# Write a list of projent hashes to a file handle.
# projent's with key "modified" => false will be
# written using the "line" key.  projent's with
# key "modified" => "true" will be written by
# constructing a new line based on their "name"
# "projid", "comment", "userlist", "grouplist"
# and "attributelist" keys.
#
sub projf_write
{
	my ($fh, $projents) = @_;
	my $projent;
	my $string;

	foreach $projent (@$projents) {

		if ($projent->{'modified'} eq 'false') {
			$string = $projent->{'line'};
		} else {
			$string = projent_2string($projent) . "\n";
		}
		print $fh "$string";
	}
}

#
# projent_parse(line)
#
# Functions for parsing the project file lines into projent hashes.
#
# Returns a number and a ref, one of:
#
# 	(0, ref to projent hash)
#	(non-zero, ref to list of errors)
#
#	Flag can be:
#		allowspaces: allow spaces between user and group names.
#		allowunits : allow units (K, M, etc), on rctl values.
#
# A projent hash contains the keys:
#
#	"name"		- string name of project
#	"projid"	- numeric id of project
#	"comment"	- comment string
#	"users"		- , seperated user list string
#	"userlist"	- list ref to list of user name strings
#	"groups"	- , seperated group list string
#	"grouplist" 	- list ref to liset of group name strings
#	"attributes"	- ; seperated attribute list string
#	"attributelist" - list ref to list of attribute refs
#		          (see projent_parse_attributes() for attribute ref)
#
sub projent_parse
{

	my ($line, $flags) = @_;
	my $projent = {};
	my ($ret, $ref);
	my @errs;
	my ($projname, $projid, $comment, $users, $groups, $attributes);

	#
	# Split fields of project line.  split() is not used because
	# we must enforce that there are 6 fields.
	#
	($projname, $projid, $comment, $users, $groups, $attributes) =
	    $line =~
	    /^([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*)$/;

	# If there is not a complete match, nothing will be defined;
	if (!defined($projname)) {
		push(@errs, [5, gettext(
		    'Incorrect number of fields.  Should have 5 ":"\'s.')]);

		# Get as many fields as we can.
		($projname, $projid, $comment, $users, $groups, $attributes) =
		    split(/:/, $line);
	}

	if (defined($projname)) {
		$projent->{'name'} = $projname;
		($ret, $ref) = projent_parse_name($projname);
		if ($ret != 0) {
			push(@errs, @$ref);
		}
	}
	if (defined($projid)) {
		$projent->{'projid'} = $projid;
		($ret, $ref) = projent_parse_projid($projid);
		if ($ret != 0) {
			push(@errs, @$ref);
		}
	}
	if (defined($comment)) {
		$projent->{'comment'} = $comment;
		($ret, $ref) = projent_parse_comment($comment);
		if ($ret != 0) {
			push(@errs, @$ref);
		}
	}
	if (defined($users)) {
		$projent->{'users'} = $users;
		($ret, $ref) = projent_parse_users($users, $flags);
		if ($ret != 0) {
			push(@errs, @$ref);
		} else {
			$projent->{'userlist'} = $ref;
		}
	}
	if (defined($groups)) {
		$projent->{'groups'} = $groups;
		($ret, $ref) = projent_parse_groups($groups, $flags);
		if ($ret != 0) {
			push(@errs, @$ref);
		} else {
			$projent->{'grouplist'} = $ref;
		}
	}
	if (defined($attributes)) {
		$projent->{'attributes'} = $attributes;
		($ret, $ref) = projent_parse_attributes($attributes, $flags);
		if ($ret != 0) {
			push(@errs, @$ref);
		} else {
			$projent->{'attributelist'} = $ref;
		}
	}

	if (@errs) {
		return (1, \@errs);

	} else {
		return (0, $projent);
	}
}

#
# Project name syntax checking.
#
sub projent_parse_name
{
	my @err;
	my ($projname) = @_;

	if (!($projname =~ /^[[:alpha:]][[:alnum:]_.-]*$/)) {
		push(@err, ([3, gettext(
		    'Invalid project name "%s", contains invalid characters'),
		    $projname]));
		return (1, \@err);
	}
	if (length($projname) > &PROJNAME_MAX) {
		push(@err, ([3, gettext(
		    'Invalid project name "%s", name too long'),
		    $projname]));
		return (1, \@err);
	}
	return (0, $projname);
}

#
# Projid syntax checking.
#
sub projent_parse_projid
{
	my @err;
	my ($projid) = @_;

	# verify projid is a positive number, and less than UID_MAX
	if (!($projid =~ /^\d+$/)) {
		push(@err, [3, gettext('Invalid projid "%s"'),
		    $projid]);
		return (1, \@err);

	} elsif ($projid > POSIX::INT_MAX) {
		push(@err, [3, gettext('Invalid projid "%s": must be <= '.
		    POSIX::INT_MAX),
		    $projid]);
		return (1, \@err);

	} else {
		return (0, $projid);
	}
}

#
# Project comment syntax checking.
#
sub projent_parse_comment
{
	my ($comment) = @_;

	# no restrictions on comments
	return (0, $comment);
}

#
# projent_parse_users(string, flags)
#
# Parses "," seperated list of users, and returns list ref to a list of
# user names.  If flags contains key "allowspaces", then spaces are
# allowed between user names and ","'s.
#
sub projent_parse_users
{
	my ($users, $flags) = @_;
	my @err;
	my $user;
	my $pattern;
	my @userlist;

	if (exists($flags->{'allowspaces'})) {
		$pattern = '\s*,\s*';
	} else {
		$pattern = ',';
	}	
	@userlist = split(/$pattern/, $users);

	# Return empty list if there are no users.
	if (!(@userlist)) {
		return (0, \@userlist);
	}

	# Verify each user name is the correct format for a valid user name.
	foreach $user (@userlist) {

		# Allow for wildcards.
		if ($user eq '*' || $user eq '!*') {
			next;
		}

		# Allow for ! operator, usernames must begin with alpha-num,
		# and contain alpha-num, '_', digits, '.', or '-'.
		if (!($user =~ /^!?[[:alpha:]][[:alnum:]_.-]*$/)) {
			push(@err, [3, gettext('Invalid user name "%s"'),
			    $user]);
			next;
		}
	}
	if (@err) {
		return (1,\ @err);
	} else {
		return (0, \@userlist);
	}
}

#
# projent_parse_groups(string, flags)
#
# Parses "," seperated list of groups, and returns list ref to a list of
# groups names.  If flags contains key "allowspaces", then spaces are
# allowed between group names and ","'s.
#
sub projent_parse_groups
{
	my ($groups, $flags) = @_;
	my @err;
	my $group;
	my $pattern;

	my @grouplist; 

	if (exists($flags->{'allowspaces'})) {
		$pattern = '\s*,\s*';
	} else {
		$pattern = ',';
	}	
	@grouplist = split(/$pattern/, $groups);

	# Return empty list if there are no groups.
	if (!(@grouplist)) {
		return (0, \@grouplist);
	}

	# Verify each group is the correct format for a valid group name.
	foreach $group (@grouplist) {

		# Allow for wildcards.
		if ($group eq '*' || $group eq '!*') {
			next;
		}
			
		# Allow for ! operator, groupnames can contain only alpha
		# characters and digits.
		if (!($group =~ /^!?[[:alnum:]]+$/)) {
			push(@err, [3, gettext('Invalid group name "%s"'),
			    $group]);
			next;
		}
	}

	if (@err) {
		return (1,\ @err);
	} else {
		return (0, \@grouplist);
	}
}

#
# projent_tokenize_attribute_values(values)
#
# Values is the right hand side of a name=values attribute/values pair.
# This function splits the values string into a list of tokens.  Tokens are
# valid string values and the characters ( ) , 
#
sub projent_tokenize_attribute_values
{
	#
	# This seperates the attribute string into higher level tokens
	# for parsing.
	#
	my $prev;
	my $cur;
	my $next;
	my $token;
	my @tokens;
	my @newtokens;
	my @err;

	# Seperate tokens delimited by "(", ")", and ",".
	@tokens = split(/([,()])/, $_[0], -1);

	# Get rid of blanks
	@newtokens = grep($_ ne '', @tokens);

	foreach $token (@newtokens) {
		if (!($token =~ /^[(),]$/ ||
		      $token =~ /^[[:alnum:]_.\/=+-]*$/)) {
			push(@err, [3, gettext(
			    'Invalid Character at or near "%s"'), $token]);
		}
	}
	if (@err) {
		return (1, \@err);
	} else {
		return (0, \@newtokens);
	}
}

#
# projent_parse_attribute_values(values)
#
# Values is the right hand side of a name=values attribute/values pair.
# This function parses the values string into a list of values.  Each value
# can be either a scalar value, or a ref to another list of values.
# A ref to the list of values is returned.
# 
sub projent_parse_attribute_values
{
	#
	# For some reason attribute values can be lists of values and
	# sublists, which are scoped using ()'s.  All values and sublists
	# are delimited by ","'s.  Empty values are lists are permitted.
	
	# This function returns a reference to a list of values, each of
	# which can be a scalar value, or a reference to a sublist.  Sublists
	# can contain both scalar values and references to furthur sublists.
	#
	my ($values) = @_;
	my $tokens;
	my @usedtokens;
	my $token;
	my $prev = '';
	my $parendepth = 0;
	my @valuestack;
	my @err;
	my ($ret, $ref);
	my $line;

	push (@valuestack, []);

	($ret, $ref) = projent_tokenize_attribute_values($values);
	if ($ret != 0) {
		return ($ret, $ref);
	}
	$tokens = $ref;

	foreach $token (@$tokens) {
		
		push(@usedtokens, $token);

		if ($token eq ',') {

			if ($prev eq ',' || $prev eq '(' ||
			    $prev eq '') {
				push(@{$valuestack[$#valuestack]}, '');
			}
			$prev = ',';
			next;
		}
		if ($token eq '(') {

			if (!($prev eq '(' || $prev eq ',' ||
			      $prev eq '')) {

				$line = join('', @usedtokens);
				push(@err, [3, gettext(
				    '"%s" <- "(" unexpected'),
				    $line]);

				return (1, \@err);
			}
				    
			$parendepth++;
			my $arrayref = [];
			push(@{$valuestack[$#valuestack]}, $arrayref);
			push(@valuestack, $arrayref);

			$prev = '(';
			next;
		}
		if ($token eq ')') {

			if ($parendepth <= 0) {

				$line = join('', @usedtokens);
				push(@err, [3, gettext(
				    '"%s" <- ")" unexpected'),
				    $line]);

				return (1, \@err);
			}

			if ($prev eq ',' || $prev eq '(') {
				push(@{$valuestack[$#valuestack]}, '');
			}
			$parendepth--;
			pop @valuestack;

			$prev = ')';
			next;
		}

		if (!($prev eq ',' || $prev eq '(' || $prev eq '')) {
			$line = join('', @usedtokens);
			push(@err, [3, gettext(
			    '"%s" <- "%s" unexpected'),
			    $line, $token]);

			return (1, \@err);
		}
				
		push(@{$valuestack[$#valuestack]}, $token);
		$prev = $token;
		next;
	}

	if ($parendepth != 0) {
		push(@err, [3, gettext(
		    '"%s" <- ")" missing'),
		    $values]);
		return (1, \@err);
	}
	
	if ($prev eq ',' || $prev eq '') {
		push(@{$valuestack[$#valuestack]}, '');
	}

	return (0, $valuestack[0]);
}

#
# projent_parse_attribute("name=values", $flags)
#
# $flags is a hash ref.
# Valid flags keys:
#	'allowunits' - allows numeric values to be scaled on certain attributes
#
# Returns a hash ref with keys:
#
#	"name" 		- name of attribute
#	"values"	- ref to list of values.
#			  Each value can be a scalar value, or a ref to
#			  a sub-list of values.
#
sub projent_parse_attribute
{
	my ($string, $flags) = @_;
	my $attribute = {};
	my ($name, $stock, $values);
	my ($ret, $ref);
	my @err;
	my $scale;
	my $num;
	my $modifier;
	my $unit;
	my $tuple;
	my $rules;
	my $rctlmax;
	my $rctlflags;

	# pattern for matching stock symbols.
	my $stockp = '[[:upper:]]{1,5}(?:.[[:upper:]]{1,5})?,';
	# Match attribute with no value.
	($name, $stock) = $string =~
	    /^(($stockp)?[[:alpha:]][[:alnum:]_.-]*)$/;
	if ($name) {
		$attribute->{'name'} = $name;
		return (0, $attribute);
	}

	# Match attribute with value list.
	($name, $stock, $values) = $string =~
	    /^(($stockp)?[[:alpha:]][[:alnum:]_.-]*)=(.*)$/;
	if ($name) {
		$attribute->{'name'} = $name;

		if (!defined($values)) {
			$values = '';
		}

		($ret, $ref) = projent_parse_attribute_values($values);
		if ($ret != 0) {
			$ref = projf_combine_errors(
			    [3,
			    gettext('Invalid value on attribute "%s"'),
			    $name], $ref);
			push(@err, @$ref);
			return ($ret, \@err)
		}

		# Scale attributes than can be scaled.
		if (exists($flags->{"allowunits"})) {

			if ($name eq 'rcap.max-rss' &&
			    defined($ref->[0]) && !ref($ref->[0])) {
				$scale = 'bytes';
				
				($num, $modifier, $unit) =
				    projent_val2num($ref->[0], $scale);
					
				if (!defined($num)) {

					if (defined($unit)) {
						push(@err, [3, gettext(
						    'rcap.max-rss has invalid '.
						    'unit "%s"'), $unit]);
					} else {
						push(@err, [3, gettext(
						    'rcap.max-rss has invalid '.
						    'value "%s"'), $ref->[0]]);
					}
				} elsif ($num eq "OVERFLOW") {
					push(@err, [3, gettext( 'rcap.max-rss value '.
				            '"%s" exceeds maximum value "%s"'),
					    $ref->[0], $MaxNum]);
				} else {
					$ref->[0] = $num;
				} 
			}
			# Check hashed cache of rctl rules.
			$rules = $RctlRules{$name};
			if (!defined($rules)) {
				#
				# See if this is an resource control name, if so
				# cache rules.
				#
				($rctlmax, $rctlflags) = rctl_get_info($name);
				if (defined($rctlmax)) {
					$rules = proj_getrctlrules(
					    $rctlmax, $rctlflags);
					if (defined($rules)) {
						$RctlRules{$name} = $rules;
					} else {
						$RctlRules{$name} =
						    "NOT AN RCTL";
					}
				}	
			}

			# Scale values if this is an rctl.
			if (defined ($rules) && ref($rules)) {
				$flags->{'type'} = $rules->{'type'};
				foreach $tuple (@$ref) {

					# Skip if tuple this is not a list.
					if (!ref($tuple)) {
						next;
					}
					# Skip if second element is not scalar.
					if (!defined($tuple->[1]) ||
					     ref($tuple->[1])) {
						next;
					}
					($num, $modifier, $unit) =
					    projent_val2num($tuple->[1],
					        $flags->{'type'});
					
					if (!defined($num)) {

						if (defined($unit)) {
							push(@err, [3, gettext(
							    'rctl %s has '.
							    'invalid unit '.
							    '"%s"'),$name,
							    $unit]);
						} else {
							push(@err, [3, gettext(
							    'rctl %s has '.
							    'invalid value '.
						            '"%s"'), $name,
							    $tuple->[1]]);
						}
					} elsif ($num eq "OVERFLOW") {
						push(@err, [3, gettext(
					            'rctl %s value "%s" '.
						    'exceeds maximum value "%s"'),
					             $name, $tuple->[1], $MaxNum]);
					} else {
						$tuple->[1] = $num;
					} 
				}
			}
		}
		$attribute->{'values'} = $ref;
		if (@err) {
			return (1, \@err);
		} else {
			return (0, $attribute);
		}

	} else {
		# Attribute did not match name[=value,value...]
		push(@err, [3, gettext('Invalid attribute "%s"'), $string]);
		return (1, \@err);
	}
}

#
# projent_parse_attributes("; seperated list of name=values pairs");
#
# Returns a list of attribute references, as returned by
# projent_parse_attribute().
#
sub projent_parse_attributes
{
	my ($attributes, $flags) = @_;
	my @attributelist;
	my @attributestrings;
	my $attributestring;
	my $attribute;
	my ($ret, $ref);
	my @errs;

	# Split up attributes by ";"'s.
	@attributestrings = split(/;/, $attributes);

	# If no attributes, return empty list.
	if (!@attributestrings) {
		return (0, \@attributelist);
	}

	foreach $attributestring (@attributestrings) {

		($ret, $ref) = projent_parse_attribute($attributestring,
		    $flags);
		if ($ret != 0) {
			push(@errs, @$ref);
		} else {
			push(@attributelist, $ref);
		}
	}

	if (@errs) {
		return (1, \@errs);
	} else {
		return (0, \@attributelist);
	}

}

#
# projent_values_equal(list A, list B)
#
# Given two references to lists of attribute values (as returned by
# projent_parse_attribute_values()), returns 1 if they are identical
# lists or 0 if they are not.
#
# XXX sub projent_values_equal;
sub projent_values_equal
{
	my ($x, $y) = @_;

	my $itema;
	my $itemb;
	my $index = 0;

	if (ref($x) && ref($y)) {

		if (scalar(@$x) != scalar(@$y)) {
			return (0);
		} else {
			foreach $itema (@$x) {
				
				$itemb = $y->[$index++];
				
				if (!projent_values_equal($itema, $itemb)) {
					return (0);
				}
			}
			return (1);
		}
	} elsif ((!ref($x) && (!ref($y)))) {
		return ($x eq $y);
	} else {
		return (0);
	}
}

#
# Converts a list of values to a , seperated string, enclosing sublists
# in ()'s.
#
sub projent_values2string
{
	my ($values) = @_;
	my $string;
	my $value;
	my @valuelist;

	if (!defined($values)) {
		return ('');
	}
	if (!ref($values)) {
		return ($values);
	}
	foreach $value (@$values) {
	    
                if (ref($value)) {
			push(@valuelist,
                            '(' . projent_values2string($value) . ')');
                } else {
			push(@valuelist, $value);
		}
        }

	$string = join(',', @valuelist)	;
	if (!defined($string)) {
		$string = '';
	}	
        return ($string);
}

#
# Converts a ref to an attribute hash with keys "name", and "values" to
# a string in the form "name=value,value...".
#
sub projent_attribute2string
{
	my ($attribute) = @_;
	my $string;

	$string = $attribute->{'name'};

	if (ref($attribute->{'values'}) && @{$attribute->{'values'}}) {
		$string = $string . '=' .
		    projent_values2string(($attribute->{'values'}));
	}	
	return ($string);				 
}

#
# Converts a ref to a projent hash (as returned by projent_parse()) to
# a project(5) database entry line.
#
sub projent_2string
{
	my ($projent) = @_;
	my @attributestrings;
	my $attribute;

	foreach $attribute (@{$projent->{'attributelist'}}) {
		push(@attributestrings, projent_attribute2string($attribute));
	}
	return (join(':', ($projent->{'name'},
			   $projent->{'projid'},
			   $projent->{'comment'},
			   join(',', @{$projent->{'userlist'}}),
			   join(',', @{$projent->{'grouplist'}}),
			   join(';', @attributestrings))));
}

#
# projf_validate(ref to list of projents hashes, flags)
#
# For each projent hash ref in the list, checks that users, groups, and pools
# exists, and that known attributes are valid.  Attributes matching rctl names
# are verified to have valid values given that rctl's global flags and max
# value.
#
# Valid flag keys:
#
#	"res" 	- allow reserved project ids 0-99
#	"dup"   - allow duplicate project ids
#
sub projf_validate
{
	my ($projents, $flags) = @_;
	my $projent;
	my $ret;
	my $ref;
	my @err;
	my %idhash;
	my %namehash;
	my %seenids;
	my %seennames;
	
	# check for unique project names
	foreach $projent (@$projents) {

		my @lineerr;

		$seennames{$projent->{'name'}}++;
		$seenids{$projent->{'projid'}}++;

		if ($seennames{$projent->{'name'}} > 1) {
			push(@lineerr, [4, gettext(
			    'Duplicate project name "%s"'),
			    $projent->{'name'}]);
		}

		if (!defined($flags->{'dup'})) {
			if ($seenids{$projent->{'projid'}} > 1) {
				push(@lineerr, [4, gettext(
				    'Duplicate projid "%s"'),
				    $projent->{'projid'}]);
			}
		}
		($ret, $ref) = projent_validate($projent, $flags);
		if ($ret != 0) {
			push(@lineerr, @$ref);
		}

		if (@lineerr) {
			
			$ref = projf_combine_errors([5, gettext(
			    'Validation error on line %d'),
			    $projent->{'linenum'}], \@lineerr);
			push(@err, @$ref);
		}
	}
	if (@err) {
		return (1, \@err);
	} else {
		return (0, $projents);
	}
}

#
# projent_validate_unique_id(
#     ref to projent hash, ref to list of projent hashes)
#
# Verifies that projid of the projent hash only exists once in the list of
# projent hashes.
#
sub projent_validate_unique_id
{
	my ($projent, $projf, $idhash) = @_;
	my @err;
	my $ret = 0;
	my $projid = $projent->{'projid'};

	if (scalar(grep($_->{'projid'} eq $projid, @$projf)) > 1) {
		$ret = 1;
		push(@err, [4, gettext('Duplicate projid "%s"'),
		    $projid]);
	}

	return ($ret, \@err);
}

#
# projent_validate_unique_id(
#     ref to projent hash, ref to list of projent hashes)
#
# Verifies that project name of the projent hash only exists once in the list
# of projent hashes.
#
# If the seconds argument is a hash ref, it is treated 
#
sub projent_validate_unique_name
{
	my ($projent, $projf, $namehash) = @_;
	my $ret = 0;
	my @err;
	my $pname = $projent->{'name'};

	if (scalar(grep($_->{'name'} eq $pname, @$projf)) > 1) {
		$ret = 1;
		push(@err,
		     [9, gettext('Duplicate project name "%s"'), $pname]);
	}

	return ($ret, \@err);
}

#
# projent_validate(ref to projents hash, flags)
#
# Checks that users, groups, and pools exists, and that known attributes
# are valid.  Attributes matching rctl names are verified to have valid
# values given that rctl's global flags and max value.
#
# Valid flag keys:
#
#	"allowspaces" 	- user and group list are allowed to contain whitespace
#	"res" 		- allow reserved project ids 0-99
#
sub projent_validate
{
	my ($projent, $flags) = @_;
	my $ret = 0;
	my $ref;
	my @err;

	($ret, $ref) =
	    projent_validate_name($projent->{'name'}, $flags);
	if ($ret != 0) {
		push(@err, @$ref);
	} 
	($ret, $ref) =
	    projent_validate_projid($projent->{'projid'}, $flags);
	if ($ret != 0) {
		push(@err, @$ref);
	} 
	($ret, $ref) =
	    projent_validate_comment($projent->{'comment'}, $flags);
	if ($ret != 0) {
		push(@err, @$ref);
	}
	($ret, $ref) =
	    projent_validate_users($projent->{'userlist'}, $flags);
	if ($ret != 0) {
		push(@err, @$ref);
	}
	($ret, $ref) =
	    projent_validate_groups($projent->{'grouplist'}, $flags);
	if ($ret != 0) {
		push(@err, @$ref);
	}
	($ret, $ref) = projent_validate_attributes(
	    $projent->{'attributelist'}, $flags);
	if ($ret != 0) {	
		push(@err, @$ref);
	}	

	my $string = projent_2string($projent);
	if (length($string) > (&PROJECT_BUFSZ - 2)) {
		push(@err, [3, gettext('projent line too long')]);
	}

	if (@err) {
		return (1, \@err);
	} else {
		return (0, $projent);
	}
}

#
# projent_validate_name(name, flags)
#
# does nothing, as any parse-able project name is valid
#
sub projent_validate_name
{
	my ($name, $flags) = @_;
	my @err;

	return (0, \@err);
	
}

#
# projent_validate_projid(projid, flags)
#
# Validates that projid is within the valid range of numbers.
# Valid flag keys:
#	"res"	- allow reserved projid's 0-99
#
sub projent_validate_projid
{
	my ($projid, $flags) = @_;	
	my @err;
	my $ret = 0;
	my $minprojid;

	if (defined($flags->{'res'})) {
		$minprojid = 0;
	} else {
		$minprojid = 100;
	}

	if ($projid < $minprojid) {

		$ret = 1;
		push(@err, [3, gettext('Invalid projid "%s": '.
		    'must be >= 100'),
		    $projid]);

	}

	return ($ret, \@err);
}

#
# projent_validate_comment(name, flags)
#
# Does nothing, as any parse-able comment is valid.
#
sub projent_validate_comment
{
	my ($comment, $flags) = @_;
	my @err;

	return (0, \@err);
}

#
# projent_validate_users(ref to list of user names, flags)
#
# Verifies that each username is either a valid glob, such
# as * or !*, or is an existing user.  flags is unused.
# Also validates that there are no duplicates.
#
sub projent_validate_users
{
	my ($users, $flags) = @_;
	my @err;
	my $ret = 0;
	my $user;
	my $username;

	foreach $user (@$users) {

		if ($user eq '*' || $user eq '!*') {
			next;
		}
		$username = $user;
		$username =~ s/^!//;

		if (!defined(getpwnam($username))) {
			$ret = 1;
			push(@err, [6,
			    gettext('User "%s" does not exist'),
			    $username]);
		}
	}

	my %seen;
        my @dups = grep($seen{$_}++ == 1, @$users);
	if (@dups) {
		$ret = 1;
		push(@err, [3, gettext('Duplicate user names "%s"'),
		    join(',', @dups)]);
	}
	return ($ret, \@err)
}

#
# projent_validate_groups(ref to list of group names, flags)
#
# Verifies that each groupname is either a valid glob, such
# as * or !*, or is an existing group.  flags is unused.
# Also validates that there are no duplicates.
#
sub projent_validate_groups
{
	my ($groups, $flags) = @_;
	my @err;
	my $ret = 0;
	my $group;
	my $groupname;

	foreach $group (@$groups) {

		if ($group eq '*' || $group eq '!*') {
			next;
		}

		$groupname = $group;
		$groupname =~ s/^!//;

		if (!defined(getgrnam($groupname))) {
			$ret = 1;
			push(@err, [6,
			    gettext('Group "%s" does not exist'),
			    $groupname]);
		}
	}

	my %seen;
        my @dups = grep($seen{$_}++ == 1, @$groups);
	if (@dups) {
		$ret = 1;
		push(@err, [3, gettext('Duplicate group names "%s"'),
		    join(',', @dups)]);
	}

	return ($ret, \@err)
}

#
# projent_validate_attribute(attribute hash ref, flags)
#
# Verifies that if the attribute's name is a known attribute or
# resource control, that it contains a valid value.
# flags is unused.
#
sub projent_validate_attribute
{
	my ($attribute, $flags) = @_;
	my $name = $attribute->{'name'};
	my $values = $attribute->{'values'};
	my $value;
	my @errs;
	my $ret = 0;
	my $result;
	my $ref;

	if (defined($values)) {
		$value = $values->[0];
	}
	if ($name eq 'task.final') {

		if (defined($values)) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'task.final should not have value')]);
		}

	# Need to rcap.max-rss needs to be a number
        } elsif ($name eq 'rcap.max-rss') {

		if (!defined($values)) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'rcap.max-rss missing value')]);
		} elsif (scalar(@$values) != 1) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'rcap.max-rss should have single value')]);
		}
		if (!defined($value) || ref($value)) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'rcap.max-rss has invalid value "%s"'),
			    projent_values2string($values)]);;
		} elsif ($value !~ /^\d+$/) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'rcap.max-rss is not an integer value: "%s"'),
			    projent_values2string($values)]);;
                } elsif ($value > $MaxNum) { 
			$ret = 1; 
			push(@errs, [3, gettext( 
			    'rcap.max-rss too large')]); 
                } 
			
	} elsif ($name eq 'project.pool') {
		if (!defined($values)) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'project.pool missing value')]);
		} elsif (scalar(@$values) != 1) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'project.pool should have single value')]);
		} elsif (!defined($value) || ref($value)) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'project.pool has invalid value "%s'),
			    projent_values2string($values)]);;
		} elsif (!($value =~ /^[[:alpha:]][[:alnum:]_.-]*$/)) {
			$ret = 1;
			push(@errs, [3, gettext(
			    'project.pool: invalid pool name "%s"'),
			    $value]);
		# Pool must exist.
		} elsif (pool_exists($value) != 0) {
			$ret = 1;
			push(@errs, [6, gettext(
			    'project.pool: pools not enabled or pool does '.
			    'not exist: "%s"'),
			    $value]);
		}
	} else {
		my $rctlmax;
		my $rctlflags;
		my $rules;

		#
		# See if rctl rules exist for this attribute.  If so, it
		# is an rctl and is checked for valid values.
		#

		# check hashed cache of rctl rules.
		$rules = $RctlRules{$name};
		if (!defined($rules)) {

			#
			# See if this is an resource control name, if so
			# cache rules.
			#
			($rctlmax, $rctlflags) = rctl_get_info($name);
			if (defined($rctlmax)) {
				$rules = proj_getrctlrules(
				    $rctlmax, $rctlflags);
				if (defined($rules)) {
					$RctlRules{$name} = $rules;
				} else {
					$RctlRules{$name} = "NOT AN RCTL";
				}
			}	
		}

		# If rules are defined, this is a resource control.
		if (defined($rules) && ref($rules)) {

			($result, $ref) =
			    projent_validate_rctl($attribute, $flags);
			if ($result != 0) {
				$ret = 1;
				push(@errs, @$ref);
			}
		}
	}
	return ($ret, \@errs);
}

#
# projent_validate_attributes(ref to attribute list, flags)
#
# Validates all attributes in list of attribute references using
# projent_validate_attribute.  flags is unused.
# flags is unused.
#
sub projent_validate_attributes
{
	my ($attributes, $flags) = @_;
	my @err;
	my $ret = 0;
	my $result = 0;
	my $ref;
	my $attribute;

	foreach $attribute (@$attributes) {

		($ret, $ref) = projent_validate_attribute($attribute, $flags);
		if ($ret != 0) {
			$result = $ret;
			push(@err, @$ref);
		}
	}

	my %seen;
        my @dups = grep($seen{$_}++ == 1, map { $_->{'name'} } @$attributes);
	if (@dups) {
		$result = 1;
		push(@err, [3, gettext('Duplicate attributes "%s"'),
		    join(',', @dups)]);
	}

	return ($result, \@err);
}

#
# projent_getrctlrules(max value, global flags)
#
# given an rctls max value and global flags, returns a ref to a hash
# of rctl rules that is used by projent_validate_rctl to validate an
# rctl's values.
# 
sub proj_getrctlrules
{
	my ($max, $flags) = @_;
	my $signals;
	my $rctl;

	$rctl = {};
	$signals = 
	    [ qw(ABRT XRES HUP STOP TERM KILL),
	      $SigNo{'ABRT'},
	      $SigNo{'XRES'},
	      $SigNo{'HUP'},
	      $SigNo{'STOP'},
	      $SigNo{'TERM'},
	      $SigNo{'KILL'} ];
	
	$rctl->{'max'} = $max;

	if ($flags & &RCTL_GLOBAL_BYTES) {
		$rctl->{'type'} = 'bytes';
	} elsif ($flags & &RCTL_GLOBAL_SECONDS) {
		$rctl->{'type'} = 'seconds';
	} elsif ($flags & &RCTL_GLOBAL_COUNT)  {
		$rctl->{'type'} = 'count';
	} else {
		$rctl->{'type'} = 'unknown';
	}
	if ($flags & &RCTL_GLOBAL_NOBASIC) {
		$rctl->{'privs'} = ['privileged', 'priv'];
	} else {
		$rctl->{'privs'} = ['basic', 'privileged', 'priv'];
	}

	if ($flags & &RCTL_GLOBAL_DENY_ALWAYS) {
		$rctl->{'actions'} = ['deny'];

	} elsif ($flags & &RCTL_GLOBAL_DENY_NEVER) {
		$rctl->{'actions'} = ['none'];
	} else {
		$rctl->{'actions'} = ['none', 'deny'];
	}

	if ($flags & &RCTL_GLOBAL_SIGNAL_NEVER) {
		$rctl->{'signals'} = [];

	} else {
		
		push(@{$rctl->{'actions'}}, 'sig');

		if ($flags & &RCTL_GLOBAL_CPU_TIME) {
			push(@$signals, 'XCPU', '30');
		}
		if ($flags & &RCTL_GLOBAL_FILE_SIZE) {
			push(@$signals, 'XFSZ', '31');
		}
		$rctl->{'signals'} = $signals;
	}
	return ($rctl);
}

#
# projent_val2num(scaled value, "seconds" | "count" | "bytes")
#
# converts an integer or scaled value to an integer value.
# returns (integer value, modifier character, unit character.
#
# On failure, integer value is undefined.  If the original
# scaled value is a plain integer, modifier character and
# unit character will be undefined.
#
sub projent_val2num
{
	my ($val, $type) = @_;
	my %scaleM = ( k => 1000,
		       m => 1000000,
		       g => 1000000000,
		       t => 1000000000000,
		       p => 1000000000000000,
		       e => 1000000000000000000);
	my %scaleB = ( k => 1024,
		       m => 1048576,
		       g => 1073741824,
		       t => 1099511627776,
		       p => 1125899906842624,
		       e => 1152921504606846976);

	my $scale;
	my $base;
	my ($num, $modifier, $unit);
	my $mul;
	my $string;
	my $i;
	my $undefined;
	my $exp_unit;

	($num, $modifier, $unit) = $val =~
	    /^(\d+(?:\.\d+)?)(?i:([kmgtpe])?([bs])?)$/;

	# No numeric match.
	if (!defined($num)) {
		return ($undefined, $undefined, $undefined);
	}

	# Decimal number with no scaling modifier.
	if (!defined($modifier) && $num =~ /^\d+\.\d+/) {
		return ($undefined, $undefined, $undefined);
	}	

	if ($type eq 'bytes') {
		$exp_unit = 'b';
		$scale = \%scaleB;
	} elsif ($type eq 'seconds') {
		$exp_unit = 's';
		$scale = \%scaleM;
	} else {
		$scale = \%scaleM;
	}

	if (defined($unit)) {
		$unit = lc($unit);
	}

	# So not succeed if unit is incorrect.
	if (!defined($exp_unit) && defined($unit)) {
		return ($undefined, $modifier, $unit);
	}
	if (defined($unit) && $unit ne $exp_unit) {
		return ($undefined, $modifier, $unit);
	}

	if (defined($modifier)) {

		$modifier = lc($modifier);
		$mul = $scale->{$modifier};
		$num = $num * $mul;
	}

	# check for integer overflow.
	if ($num > $MaxNum) {
		return ("OVERFLOW", $modifier, $unit);
	}
	#
	# Trim numbers that are decimal equivalent to the maximum value
	# to the maximum integer value.
	#
	if ($num == $MaxNum) {
		$num = $MaxNum;;

	} elsif ($num < $MaxNum) {
		# convert any decimal numbers to an integer
		$num = int($num);
	}

	return ($num, $modifier, $unit);
}
#
# projent_validate_rctl(ref to rctl attribute hash, flags)
#
# verifies that the given rctl hash with keys "name" and
# "values" contains valid values for the given name.
# flags is unused.
#
sub projent_validate_rctl
{
	my ($rctl, $flags) = @_;
	my $allrules;
	my $rules;
	my $name;
	my $values;
	my $value;
	my $valuestring;
	my $ret = 0;
	my @err;
	my $priv;
	my $val;
	my @actions;
	my $action;
	my $signal;
	my $sigstring;	# Full signal string on right hand of signal=SIGXXX.
	my $signame;	# Signal number or XXX part of SIGXXX.
	my $siglist;
	my $nonecount;
	my $denycount;
	my $sigcount;

	$name = $rctl->{'name'};
	$values = $rctl->{'values'};

	#
	# Get the default rules for all rctls, and the specific rules for
	# this rctl.
	#
	$allrules = $RctlRules{'__DEFAULT__'};
	$rules = $RctlRules{$name};

	if (!defined($rules) || !ref($rules)) {
		$rules = $allrules;
	}

	# Allow for no rctl values on rctl.
	if (!defined($values)) {
		return (0, \@err);
	}

	# If values exist, make sure it is a list.
	if (!ref($values)) {

		push(@err, [3, gettext(
		    'rctl "%s" missing value'), $name]);
		return (1, \@err);
	}

	foreach $value (@$values) {

		# Each value should be a list.

		if (!ref($value)) {
			$ret = 1;
			push(@err, [3, gettext(
			    'rctl "%s" value "%s" should be in ()\'s'),
				     $name, $value]);
			
			next;
		}

		($priv, $val, @actions) = @$value;
		if (!@actions) {
			$ret = 1;
			$valuestring = projent_values2string([$value]);
			push(@err, [3, gettext(
			    'rctl "%s" value missing action "%s"'),
			    $name, $valuestring]);
		}

		if (!defined($priv)) {
			$ret = 1;
			push(@err, [3, gettext(
			    'rctl "%s" value missing privilege "%s"'),
			    $name, $valuestring]);

		} elsif (ref($priv)) {
			$ret = 1;
			$valuestring = projent_values2string([$priv]);
			push(@err, [3, gettext(
			    'rctl "%s" invalid privilege "%s"'),
				     $name, $valuestring]);

		} else {
			if (!(grep /^$priv$/, @{$allrules->{'privs'}})) {
				
				$ret = 1;
				push(@err, [3, gettext(
			            'rctl "%s" unknown privilege "%s"'),
				    $name, $priv]);

			} elsif (!(grep /^$priv$/, @{$rules->{'privs'}})) {

				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" privilege not allowed '.
				    '"%s"'), $name, $priv]);
			}
		}
		if (!defined($val)) {
			$ret = 1;
			push(@err, [3, gettext(
			    'rctl "%s" missing value'), $name]);

		} elsif (ref($val)) {
			$ret = 1;
			$valuestring = projent_values2string([$val]);
			push(@err, [3, gettext(
			    'rctl "%s" invalid value "%s"'),
				     $name, $valuestring]);
		
		} else {
			if ($val !~ /^\d+$/) {
				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" value "%s" is not '.
				    'an integer'), $name, $val]);

			} elsif ($val > $rules->{'max'}) {
				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" value "%s" exceeds '.
				    'system limit'), $name, $val]);
			}
		}
		$nonecount = 0;
		$denycount = 0;
		$sigcount = 0;

		foreach $action (@actions) {

			if (ref($action)) {
				$ret = 1;
				$valuestring =
				    projent_values2string([$action]);
				push(@err, [3, gettext(
				    'rctl "%s" invalid action "%s"'),
				     $name, $valuestring]);

				next;
			}

			if ($action =~ /^sig(nal)?(=.*)?$/) {
				$signal = $action;
				$action = 'sig';
			}
			if (!(grep /^$action$/, @{$allrules->{'actions'}})) {
			
				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" unknown action "%s"'),
				    $name, $action]);
				next;

			} elsif (!(grep /^$action$/, @{$rules->{'actions'}})) {

				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" action not allowed "%s"'),
				    $name, $action]);
				next;
			}
		
			if ($action eq 'none') {
				if ($nonecount >= 1) {

					$ret = 1;
					push(@err, [3, gettext(
				    	    'rctl "%s" duplicate action '.
					    'none'), $name]);
				}
				$nonecount++;
				next;
			}
			if ($action eq 'deny') {
				if ($denycount >= 1) {

					$ret = 1;
					push(@err, [3, gettext(
				    	    'rctl "%s" duplicate action '.
					    'deny'), $name]);
				}
				$denycount++;
				next;
			}

			# action must be signal
			if ($sigcount >= 1) {

				$ret = 1;
				push(@err, [3, gettext(
			    	    'rctl "%s" duplicate action sig'),
			    	    $name]);
			}	
			$sigcount++;

			#
			# Make sure signal is correct format, one of:
			# sig=##
			# signal=##
			# sig=SIGXXX
			# signal=SIGXXX
			# sig=XXX
			# signal=SIGXXX
			#
			($sigstring) = $signal =~
			    /^
				 (?:signal|sig)=
				     (\d+|
				     (?:SIG)?[[:upper:]]+(?:[+-][123])?
				 )
			     $/x;

			if (!defined($sigstring)) {
				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" invalid signal "%s"'),
				    $name, $signal]);
				next;
			}

			$signame = $sigstring;
			$signame =~ s/SIG//;
			
			# Make sure specific signal is allowed.
			$siglist = $allrules->{'signals'};
			if (!(grep /^$signame$/, @$siglist)) {
				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" invalid signal "%s"'),
				    $name, $signal]);
				next;
			}
			$siglist = $rules->{'signals'};

			if (!(grep /^$signame$/, @$siglist)) {
				$ret = 1;
				push(@err, [3, gettext(
				    'rctl "%s" signal not allowed "%s"'),
				    $name, $signal]);
				next;
			}
		}

		if ($nonecount && ($denycount || $sigcount)) {
			$ret = 1;
			push(@err, [3, gettext(
			    'rctl "%s" action "none" specified with '.
			    'other actions'), $name]);
		}
	}

	if (@err) {
		return ($ret, \@err);
	} else {
	    return ($ret, \@err);
	}
}

1;
/*
 * Copyright (c) 1999, 2007, Oracle and/or its affiliates. All rights reserved.
 * Copyright (c) 2014 Racktop Systems.
 */
/*
 * Project.xs contains XS wrappers for the project database maniplulation
 * functions as provided by libproject and described in getprojent(3EXACCT).
 */

/* Solaris includes. */
#include <zone.h>
#include <project.h>
#include <pool.h>
#include <sys/pool_impl.h>
#include <rctl.h>
#include <stdio.h>

/* Perl includes. */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/*
 * Convert and save a struct project on the perl XS return stack.
 * In a void context it returns nothing, in a scalar context it returns just
 * the name of the project and in a list context it returns a 6-element list
 * consisting of (name, projid, comment, users, groups, attr), where users and
 * groups are references to arrays containing the appropriate lists.
 */
static int
pushret_project(const struct project *proj)
{
	char	**cp;
	AV	*ary;

	dSP;
	if (GIMME_V == G_SCALAR) {
		EXTEND(SP, 1);
		PUSHs(sv_2mortal(newSVpv(proj->pj_name, 0)));
		PUTBACK;
		return (1);
	} else if (GIMME_V == G_ARRAY) {
		EXTEND(SP, 6);
		PUSHs(sv_2mortal(newSVpv(proj->pj_name, 0)));
		PUSHs(sv_2mortal(newSViv(proj->pj_projid)));
		PUSHs(sv_2mortal(newSVpv(proj->pj_comment, 0)));
		ary = newAV();
		for (cp = proj->pj_users; *cp != NULL; cp++) {
			av_push(ary, newSVpv(*cp, 0));
		}
		PUSHs(sv_2mortal(newRV_noinc((SV *)ary)));
		ary = newAV();
		for (cp = proj->pj_groups; *cp != NULL; cp++) {
			av_push(ary, newSVpv(*cp, 0));
		}
		PUSHs(sv_2mortal(newRV_noinc((SV *)ary)));
		PUSHs(sv_2mortal(newSVpv(proj->pj_attr, 0)));
		PUTBACK;
		return (6);
	} else {
		return (0);
	}
}

static int
pwalk_cb(const projid_t project, void *walk_data)
{
	int *nitemsp;

	dSP;
	nitemsp = (int *) walk_data;
	EXTEND(SP, 1);
	PUSHs(sv_2mortal(newSViv(project)));
	(*nitemsp)++;
	PUTBACK;
	return (0);
}

/*
 * The XS code exported to perl is below here.  Note that the XS preprocessor
 * has its own commenting syntax, so all comments from this point on are in
 * that form.  Note also that the PUTBACK; lines are necessary to synchronise
 * the local and global views of the perl stack before calling pushret_project,
 * as the code generated by the perl XS compiler twiddles with the stack on
 * entry to an XSUB.
 */

MODULE = Sun::Solaris::Project PACKAGE = Sun::Solaris::Project
PROTOTYPES: ENABLE

 #
 # Define any constants that need to be exported.  By doing it this way we can
 # avoid the overhead of using the DynaLoader package, and in addition constants
 # defined using this mechanism are eligible for inlining by the perl
 # interpreter at compile time.
 #
BOOT:
	{
	HV *stash;
	char buf[128];
	stash = gv_stashpv("Sun::Solaris::Project", TRUE);
	newCONSTSUB(stash, "MAXPROJID", newSViv(MAXPROJID));
	newCONSTSUB(stash, "PROJNAME_MAX", newSViv(PROJNAME_MAX));
	newCONSTSUB(stash, "PROJF_PATH",
	    newSVpv(PROJF_PATH, sizeof (PROJF_PATH) - 1));
	newCONSTSUB(stash, "PROJECT_BUFSZ", newSViv(PROJECT_BUFSZ));
	newCONSTSUB(stash, "SETPROJ_ERR_TASK", newSViv(SETPROJ_ERR_TASK));
	newCONSTSUB(stash, "SETPROJ_ERR_POOL", newSViv(SETPROJ_ERR_POOL));
	newCONSTSUB(stash, "RCTL_GLOBAL_NOBASIC",
		newSViv(RCTL_GLOBAL_NOBASIC));
	newCONSTSUB(stash, "RCTL_GLOBAL_LOWERABLE",
		newSViv(RCTL_GLOBAL_LOWERABLE));
	newCONSTSUB(stash, "RCTL_GLOBAL_DENY_ALWAYS",
		newSViv(RCTL_GLOBAL_DENY_ALWAYS));
	newCONSTSUB(stash, "RCTL_GLOBAL_DENY_NEVER",
		newSViv(RCTL_GLOBAL_DENY_NEVER));
	newCONSTSUB(stash, "RCTL_GLOBAL_FILE_SIZE",
		newSViv(RCTL_GLOBAL_FILE_SIZE));
	newCONSTSUB(stash, "RCTL_GLOBAL_CPU_TIME",
		newSViv(RCTL_GLOBAL_CPU_TIME));
	newCONSTSUB(stash, "RCTL_GLOBAL_SIGNAL_NEVER",
		newSViv(RCTL_GLOBAL_SIGNAL_NEVER));
	newCONSTSUB(stash, "RCTL_GLOBAL_INFINITE",
		newSViv(RCTL_GLOBAL_INFINITE));
	newCONSTSUB(stash, "RCTL_GLOBAL_UNOBSERVABLE",
		newSViv(RCTL_GLOBAL_UNOBSERVABLE));
	newCONSTSUB(stash, "RCTL_GLOBAL_BYTES",
		newSViv(RCTL_GLOBAL_BYTES));
	newCONSTSUB(stash, "RCTL_GLOBAL_SECONDS",
		newSViv(RCTL_GLOBAL_SECONDS));
	newCONSTSUB(stash, "RCTL_GLOBAL_COUNT",
		newSViv(RCTL_GLOBAL_COUNT));
	sprintf(buf, "%llu", UINT64_MAX);
	newCONSTSUB(stash, "RCTL_MAX_VALUE",
		newSVpv(buf, strlen(buf)));
	}

projid_t
getprojid()

int
setproject(name, user_name, flags)
	const char	*name;
	const char	*user_name
	uint_t		flags

void
activeprojects()
PREINIT:
	int	nitems;
PPCODE:
	PUTBACK;
	nitems = 0;
	project_walk(&pwalk_cb, (void*)&nitems);
	XSRETURN(nitems);

void
getprojent()
PREINIT:
	struct project	proj, *projp;
	char		buf[PROJECT_BUFSZ];
PPCODE:
	PUTBACK;
	if ((projp = getprojent(&proj, buf, sizeof (buf)))) {
		XSRETURN(pushret_project(projp));
	} else {
		XSRETURN_EMPTY;
	}

void
setprojent()

void
endprojent()

void
getprojbyname(name)
	char	*name
PREINIT:
	struct project	proj, *projp;
	char		buf[PROJECT_BUFSZ];
PPCODE:
	PUTBACK;
	if ((projp = getprojbyname(name, &proj, buf, sizeof (buf)))) {
		XSRETURN(pushret_project(projp));
	} else {
		XSRETURN_EMPTY;
	}

void
getprojbyid(id)
	projid_t	id
PREINIT:
	struct project	proj, *projp;
	char		buf[PROJECT_BUFSZ];
PPCODE:
	PUTBACK;
	if ((projp = getprojbyid(id, &proj, buf, sizeof (buf)))) {
		XSRETURN(pushret_project(projp));
	} else {
		XSRETURN_EMPTY;
	}

void
getdefaultproj(user)
	char	*user
PREINIT:
	struct project	proj, *projp;
	char		buf[PROJECT_BUFSZ];
PPCODE:
	PUTBACK;
	if ((projp = getdefaultproj(user, &proj, buf, sizeof (buf)))) {
		XSRETURN(pushret_project(projp));
	} else {
		XSRETURN_EMPTY;
	}

void
fgetprojent(fh)
	FILE	*fh
PREINIT:
	struct project	proj, *projp;
	char		buf[PROJECT_BUFSZ];
PPCODE:
	PUTBACK;
	if ((projp = fgetprojent(fh, &proj, buf, sizeof (buf)))) {
		XSRETURN(pushret_project(projp));
	} else {
		XSRETURN_EMPTY;
	}

bool
inproj(user, proj)
	char	*user
	char	*proj
PREINIT:
	char	buf[PROJECT_BUFSZ];
CODE:
	RETVAL = inproj(user, proj, buf, sizeof (buf));
OUTPUT:
	RETVAL


int
getprojidbyname(proj)
	char	*proj
PREINIT:
	int	id;
PPCODE:
	if ((id = getprojidbyname(proj)) == -1) {
		XSRETURN_UNDEF;
	} else {
		XSRETURN_IV(id);
	}


# rctl_get_info(name)
#
# For the given rctl name, returns the list
# ($max, $flags), where $max is the integer value
# of the system rctl, and $flags are the rctl's
# global flags, as returned by rctlblk_get_global_flags
#
# This function is private to Project.pm
void
rctl_get_info(name)
	char	*name
PREINIT:
	rctlblk_t *blk1 = NULL;
	rctlblk_t *blk2 = NULL;
	rctlblk_t *tmp = NULL;
	rctl_priv_t priv;
	rctl_qty_t value;
	int flags = 0;
	int ret;
	int err = 0;
	char string[24];	/* 24 will always hold a uint64_t */
PPCODE:
	Newc(0, blk1, rctlblk_size(), char, rctlblk_t);
	if (blk1 == NULL) {
		err = 1;
		goto out;
	}
	Newc(1, blk2, rctlblk_size(), char, rctlblk_t);
	if (blk2 == NULL) {
		err = 1;
		goto out;
	}
	ret = getrctl(name, NULL, blk1, RCTL_FIRST);
	if (ret != 0) {
		err = 1;
		goto out;
	}
	priv = rctlblk_get_privilege(blk1);
	while (priv != RCPRIV_SYSTEM) {
		tmp = blk2;
		blk2 = blk1;
		blk1 = tmp;
		ret = getrctl(name, blk2, blk1, RCTL_NEXT);
		if (ret != 0) {
			err = 1;
			goto out;
		}
		priv = rctlblk_get_privilege(blk1);
	}
	value = rctlblk_get_value(blk1);
	flags = rctlblk_get_global_flags(blk1);
	ret = sprintf(string, "%llu", value);
	if (ret <= 0) {
		err = 1;
	}
	out:
	if (blk1)
		Safefree(blk1);
	if (blk2)
		Safefree(blk2);
	if (err)
		XSRETURN(0);

	XPUSHs(sv_2mortal(newSVpv(string, 0)));
	XPUSHs(sv_2mortal(newSViv(flags)));
	XSRETURN(2);

#
# pool_exists(name)
#
# Returns 0 a pool with the given name exists on the current system.
# Returns 1 if pools are disabled or the pool does not exist
#
# Used internally by project.pm to validate the project.pool attribute
#
# This function is private to Project.pm
void
pool_exists(name)
	char	*name
PREINIT:
	pool_conf_t *conf;
	pool_t *pool;
	pool_status_t status;
	int fd;
PPCODE:

	/*
	 * Determine if pools are enabled using /dev/pool directly, as
	 * libpool may not be present.
	 */
	if (getzoneid() != GLOBAL_ZONEID) {
		XSRETURN_IV(1);
	}
	if ((fd = open("/dev/pool", O_RDONLY)) < 0) {
		XSRETURN_IV(1);
	}
	if (ioctl(fd, POOL_STATUSQ, &status) < 0) {
		(void) close(fd);
		XSRETURN_IV(1);
	}
	close(fd);
	if (status.ps_io_state != 1) {
		XSRETURN_IV(1);
	}

	/*
	 * If pools are enabled, assume libpool is present.
	 */
	conf = pool_conf_alloc();
	if (conf == NULL) {
		XSRETURN_IV(1);
	}
	if (pool_conf_open(conf, pool_dynamic_location(), PO_RDONLY)) {
		pool_conf_free(conf);
		XSRETURN_IV(1);
	}
	pool = pool_get_pool(conf, name);
	if (pool == NULL) {
		pool_conf_close(conf);
		pool_conf_free(conf);
		XSRETURN_IV(1);
	}
	pool_conf_close(conf);
	pool_conf_free(conf);
	XSRETURN_IV(0);

#
# Copyright (c) 2003, Oracle and/or its affiliates. All rights reserved.
#

Licensing
---------
This module is released under the Perl Artistic License.

Availability
------------
This module is only available for Solaris 9 onwards.

Description
-----------
This module provided access to the Solaris Project subsystem, which is part of
the Solaris resource management infrastructure.

For more information on Solaris Projects, see the project(5) manpage and the
following on-line documentation:

System Administration Guide: Resource Management and Network Services
Chapter 6 - Projects and Tasks
http://docs.sun.com/db/doc/816-7125

An example of how this module might be used is to put the Apache httpd under
resource management control, so that the total resources used by Apache can be
limited using Solaris resource management.  Assuming mod_perl is installed for
Apache, and a project with the appropriate limits has been established
(see documentation references above), the following code in the Apache Perl
startup file will place Apache under RM control:

use Sun::Solaris::Project qw(:ALL);
my $user = getpwuid(Apache->server->uid());
setproject(getdefaultproj($user), $user, 0) == 0 || die($!);

Installation
------------

1. Uncompress and untar the archive
2. cd to the module directory
3. perl Makefile.PL; make install

If you are using gcc and wish to build this module against the perl shipped as
part of Solaris, see the Solaris-PerlGcc module, also available from CPAN.
#
# Copyright (c) 2000, 2008, Oracle and/or its affiliates. All rights reserved.
#

This module is released as Public Source via the Comprehensive Perl Archive
Network (http://www.cpan.org).  If it is updated for any reason, a new
release should be pushed to CPAN.

The version number of this module is derived from the $VERSION variable in
Project.pm.  If anything under this directory is modified, $VERSION should be 
changed in Project.pm to update the module version number correctly.  If this 
is not done, it will not be possible to upload the generated archive to CPAN, 
as CPAN requires that uploaded archives have unique names.

To prepare the contents of the directory for release, they should be packaged
up as a .tar.gz archive.  The procedure for this is:

$ /usr/perl5/bin/perl Makefile.PL
$ make tardist

This will produce the file for upload to CPAN.  Contact cpan-support@sun.com
for details of how to do this.
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#

# Copyright 2022, Richard Lowe.

include ../Makefile.com
include $(SRC)/cmd/perl/Makefile.perl.64

all: $(PERLEXT)
install: $(ROOTPERLEXT) $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright (c) 2014 Racktop Systems.
#

$mapfile_version 2

SYMBOL_SCOPE {
    global:
	boot_Sun__Solaris__Project;
	XS_Sun__Solaris__Project_activeprojects;
	XS_Sun__Solaris__Project_endprojent;
	XS_Sun__Solaris__Project_fgetprojent;
	XS_Sun__Solaris__Project_getdefaultproj;
	XS_Sun__Solaris__Project_getprojbyid;
	XS_Sun__Solaris__Project_getprojbyname;
	XS_Sun__Solaris__Project_getprojent;
	XS_Sun__Solaris__Project_getprojid;
	XS_Sun__Solaris__Project_getprojidbyname;
	XS_Sun__Solaris__Project_inproj;
	XS_Sun__Solaris__Project_pool_exists;
	XS_Sun__Solaris__Project_rctl_get_info;
	XS_Sun__Solaris__Project_setproject;
	XS_Sun__Solaris__Project_setprojent;
    local:
	*;
};
#
# Copyright (c) 2002, 2003, Oracle and/or its affiliates. All rights reserved.
#

#
# Sun::Solaris::Project documentation.
# 

=head1 NAME

Sun::Solaris::Project - Perl interface to Projects

=head1 SYNOPSIS

 use Sun::Solaris::Project qw(:ALL);
 my $projid = getprojid();

This module provides wrappers for the Project-related system calls and the
C<libproject(3LIB)> library. Also provided are constants from the various
Project-related headers.

=head2 Constants

C<MAXPROJID>, C< PROJNAME_MAX>, C<PROJF_PATH>, C<PROJECT_BUFSZ>,
C<SETPROJ_ERR_TASK>, and C<SETPROJ_ERR_POOL>.

=head2 Functions

B<C<getprojid()>>

This function returns the numeric project ID of the calling process or C<undef>
if the underlying C<getprojid(2)> system call is unsuccessful.

B<C<setproject($project, $user, $flags)>>

If C<$user> is a member of the project specified by C<$project>,
C<setproject()> creates a new task and associates the appropriate resource
controls with the process, task, and project. This function returns 0 on
success. If the the underlying task creation fails, C<SETPROJ_ERR_TASK> is
returned. If pool assignment fails, C<SETPROJ_ERR_POOL> is returned. If any
resource attribute assignments fail, an integer value corresponding to the
offset of the failed attribute assignment in the project database is returned.
See C<setproject(3PROJECT)>.

B<C<activeprojects()>>

This function returns a list of the currently active projects on the system.
Each value in the list is the numeric ID of a currently active project.

B<C<getprojent()>>

This function returns the next entry from the project database. When called in
a scalar context, C<getprojent()> returns only the name of the project. When
called in a list context, C<getprojent()> returns a 6-element list consisting
of:

 ($name, $projid, $comment, \@users, \@groups, $attr)

C<\@users> and C<\@groups> are returned as arrays containing the appropriate
user or project lists. On end-of-file C<undef> is returned.

B<C<setprojent()>>

This function rewinds the project database to the beginning of the file.

B<C<endprojent()>>

This function closes the project database.

B<C<getprojbyname($name)>>

This function searches the project database for an entry with the specified
name. It returns a 6-element list as returned by C<getprojent()> if the entry
is found and C<undef> if it cannot be found.

B<C<getprojbyid($id)>>

This function searches the project database for an entry with the specified
ID. It returns a 6-element list as returned by C<getprojent()> if the entry is
found or C<undef> if it cannot be found.

B<C<getdefaultproj($user)>>

This function returns the default project entry for the specified user in the
same format as C<getprojent()>. It returns C<undef> if the user cannot be
found. See C<getdefaultproj(3PROJECT)> for information about the lookup
process.

B<C<fgetprojent($filehandle)>>

This function returns the next project entry from C<$filehandle>, a Perl file
handle that must refer to a previously opened file in C<project(5)> format.
Return values are the same as for C<getprojent()>.

B<C<inproj($user, $project)>>

This function checks whether the specified user is able to use the project.
This function returns C<true> if the user can use the project and C<false>
otherwise. See C<inproj(3PROJECT)>.

B<C<getprojidbyname($project)>>

This function searches the project database for the specified project. It
returns the project ID if the project is found and C<undef> if it is not found.

=head2 Class methods

None.

=head2 Object methods

None.

=head2 Exports

By default nothing is exported from this module. The following tags can be
used to selectively import constants and functions defined in this module:

 :SYSCALLS    getprojid()

 :LIBCALLS    setproject(), activeprojects(), getprojent(), setprojent(),
              endprojent(), getprojbyname(), getprojbyid(), getdefaultproj(),
              fgetprojent(), inproj(), and getprojidbyname()

 :CONSTANTS   MAXPROJID, PROJNAME_MAX, PROJF_PATH, PROJECT_BUFSZ,
              SETPROJ_ERR_TASK, and SETPROJ_ERR_POOL

 :ALL         :SYSCALLS, :LIBCALLS, and :CONSTANTS

=head1 ATTRIBUTES

See C<attributes(7)> for descriptions of the following attributes:

  ___________________________________________________________
 |       ATTRIBUTE TYPE        |       ATTRIBUTE VALUE       |
 |_____________________________|_____________________________|
 | Availability                | CPAN (http://www.cpan.org)  |
 |_____________________________|_____________________________|
 | Interface Stability         | Evolving                    |
 |_____________________________|_____________________________|

=head1 SEE ALSO

C<getprojid(2)>, C<getdefaultproj(3PROJECT)>, C<inproj(3PROJECT)>,
C<libproject(3LIB)>, C<setproject(3PROJECT)>, C<project(5)>, C<attributes(7)>
#
# Copyright (c) 2000, 2005 Oracle and/or its affiliates. All rights reserved.
#

#
# test script for Sun::Solaris::Project
#

use warnings;
use strict;
use Data::Dumper;
$Data::Dumper::Terse = 1;
$Data::Dumper::Indent = 0;

sub cleanup {
	unlink("/tmp/project.$$.1");
	unlink("/tmp/project.$$.2");
	unlink("/tmp/project.$$.3");
	unlink("/tmp/project.$$.4");
	unlink("/tmp/project.$$.5");
	unlink("/tmp/project.$$.1.w");
	unlink("/tmp/project.$$.2.w");
	unlink("/tmp/project.$$.3.w");
	unlink("/tmp/project.$$.4.w");
	unlink("/tmp/project.$$.5.w");
	unlink("/tmp/projent.$$");
}

# 'use Sun::Solaris::Project;' counts as test 1
our $test = 1;
our $intest = 1;
our $loaded = 0;

#
# Status reporting utils
#
# Expected calling sequence is:
#	start()
#	pass() or fail()
#	start()
#	pass() or fail()
#	...
#	...
#
#	Calling start() twice in a row will fail test.
#	Calling start() and then exiting will fail test.
#
sub start
{
	if ($intest != 0) {
		fatal("Started new test before finishing previous.");
	}
	$test++;
	$intest = 1;
	print "# Starting Test $test: @_\n" if (@_);
}

sub pass
{
	if ($intest == 0) {
		fatal("pass() without start()");
	}
	print("ok $test @_\n");
	$intest = 0;
}

sub fail
{
	if ($intest == 0) {
		fatal("fail() without start()");
	}
	print("not ok $test @_\n");
	$intest = 0;
}

sub fatal
{
	print(STDERR "FATAL!\n");
	print("not ok $test @_\n");
	exit(1);
}

sub comment
{
	print("# @_\n");
}

#
# Read in a project file and build into the same data structure that we will
# get if we do the same with the getXXX functions
#

sub read_pfile
{
	my ($fh) = @_;
	my ($line, @a1, @a2);
	while (defined($line = <$fh>)) {
		chomp($line);
		@a2 = split(/:/, $line, 6);
		$a2[2] = '' if (! defined($a2[2]));
		$a2[3] = defined($a2[3]) ? [ split(/,/, $a2[3]) ] : [];
		$a2[4] = defined($a2[4]) ? [ split(/,/, $a2[4]) ] : [];
		$a2[5] = '' if (! defined($a2[5]));
		push(@a1, [ @a2 ]);
	}
	return(\@a1);
}

#
# Compare two arrays of project structures & check for equivalence.
# Converts each into a string using Data::Dumper and then does a string
# comparison.  Dirty but effective :-)
#

sub cmp_recs
{
	my ($a1, $a2) = @_;
	my $s1 = Dumper($a1);
	my $s2 = Dumper($a2);

	# Make sure numbers and quoted numbers compare the same
	$s1 =~ s/'([+-]?[\d.]+)'/$1/g;
	$s2 =~ s/'([+-]?[\d.]+)'/$1/g;

	return($s1 eq $s2);
}

sub hash2string
{
	my ($key, $value);
	my @strings;
	my $string;
	my $hash = $_[0];
	foreach $key (keys(%$hash)) {
		push(@strings, "$key => $hash->{$key}");
	}
	$string = "{ " . join(", ", @strings) . " }";
	return ($string);
}

#
# Main body of tests starts here.
#

# Check the module loads.
BEGIN {
	$| = 1;
	print "1..548\n";
}

END {
	fail("not ok 1") unless ($loaded);
	fail("Exited during test!") if ($intest == 1);
	cleanup();
}

use Sun::Solaris::Project qw(:ALL :PRIVATE);
$loaded = 1;
pass();

start("Check the constants.");
my ($fh, $line, $n1, $n2, $n3, $s);
open($fh, "</usr/include/project.h") || fatal($!);
while (defined($line = <$fh>)) {
	$n1 = $1 if ($line =~ /#define\s+PROJNAME_MAX\s+(\d+)/);
	$n2 = $1 if ($line =~ /#define\s+PROJECT_BUFSZ\s+(\d+)/);
	$s = $1 if ($line =~ /#define\s+PROJF_PATH\s+"([^"]+)"/);
}
close($fh);
open($fh, "</usr/include/sys/param.h") || fatal($!);
while (defined($line = <$fh>)) {
	$n3 = $1 if ($line =~ /#define\s+MAXUID\s+(\d+)/);
}
close($fh);
if (! defined($s) || ! defined($n1) || ! defined($n2)) {
	fail();
} else {
	if ($n1 == &PROJNAME_MAX && $n2 == &PROJECT_BUFSZ &&
	    $n3 == &MAXPROJID && $s eq &PROJF_PATH) {
		pass();
	} else {
		fail();
	}
}

#
# projf_read on various files with various flags.
#
# This table represents when projf_read should fail given a file
# and flags.
#
# file/flags  # {}	validate	validate,res	validate,dup	
# ###################################################################
# parse error #	no	no		no		no
# dup names   #	yes	no		no		no	
# dup ids     #	yes	no		no		yes
# system ids  #	yes	no		yes		no
# all user    #	yes	yes		yes		yes
#

my $flags1 = {};
my $flags2 = { "validate" => "true" };
my $flags3 = { "validate" => "true", "res" => 1 };
my $flags4 = { "validate" => "true", "dup" => 1 };

# Make a temporary project files.
my ($ret, $file1, $file2, $file3, $file4, $file5, $pass);

# file1, parse error (extra ":") on group.staff project.
open($file1, "+>/tmp/project.$$.1") || fatal($!);
print $file1 <<EOF;
test1:123:project one:root,bin:adm:attr1=a;attr2=b
user.test2:456:project two:adm,uucp:staff:attr1=p;attr2=q
group.test3:678:project three::root,nobody:root,lp:attr1=y;attr2=z
test4:678:project four:root:root:
test5:679:project five::sys:
test6:690::::
EOF

# file2, duplicate project names.
open($file2, "+>/tmp/project.$$.2") || fatal($!);
print $file2 <<EOF;
test1:123:project one:root,bin:adm:attr1=a;attr2=b
user.test2:456:project two:adm,uucp:staff:attr1=p;attr2=q
group.test3:677:project three:root,nobody:root,lp:attr1=y;attr2=z
test1:678:project four:root:root:
test5:679:project five::sys:
test6:690::::
EOF

# file3, duplicate project ids.
open($file3, "+>/tmp/project.$$.3") || fatal($!);
print $file3 <<EOF;
test1:123:project one:root,bin:adm:attr1=a;attr2=b
user.test2:456:project two:adm,uucp:staff:attr1=p;attr2=q
group.test3:677:project three:root,nobody:root,lp:attr1=y;attr2=z
test4:678:project four:root:root:
test5:678:project five::sys:
test6:690::::
EOF

# file4, system project ids.
open($file4, "+>/tmp/project.$$.4") || fatal($!);
print $file4 <<EOF;
system:0::::
user.root:1::::
noproject:2::::
default:3::::
group.staff:10::::
test1:123:project one:root,bin:adm:attr1=a;attr2=b
user.test2:456:project two:adm,uucp:staff:attr1=p;attr2=q
group.test3:677:project three:root,nobody:root,lp:attr1=y;attr2=z
test4:678:project four:root:root:
test5:679:project five::sys:
test6:690::::
EOF

# file5, all unique user projects.
open($file5, "+>/tmp/project.$$.5") || fatal($!);
print $file5 <<EOF;
test1:123:project one:root,bin:adm:attr1=a;attr2=b
user.test2:456:project two:adm,uucp:staff:attr1=p;attr2=q
group.test3:677:project three:root,nobody:root,lp:attr1=y;attr2=z
test4:678:project four:root:root:
test5:679:project five::sys:
test6:690::::
EOF

#
# Each test is the file description, input file, filename, flags, and the expected
# return value.
#
my @read_tests = (
	[ "parse error", $file1, "/tmp/project.$$.1", $flags1, 1 ],
	[ "parse error", $file1, "/tmp/project.$$.1", $flags2, 1 ],
	[ "parse error", $file1, "/tmp/project.$$.1", $flags3, 1 ],
	[ "parse error", $file1, "/tmp/project.$$.1", $flags4, 1 ],
	[ "dup names", $file2, "/tmp/project.$$.2", $flags1, 0 ],
	[ "dup names", $file2, "/tmp/project.$$.2", $flags2, 1 ],
	[ "dup names", $file2, "/tmp/project.$$.2", $flags3, 1 ],
	[ "dup names", $file2, "/tmp/project.$$.2", $flags4, 1 ],
	[ "dup ids", $file3, "/tmp/project.$$.3", $flags1, 0 ],
	[ "dup ids", $file3, "/tmp/project.$$.3", $flags2, 1 ],
	[ "dup ids", $file3, "/tmp/project.$$.3", $flags3, 1 ],
	[ "dup ids", $file3, "/tmp/project.$$.3", $flags4, 0 ],
	[ "sys ids", $file4, "/tmp/project.$$.4", $flags1, 0 ],
	[ "sys ids", $file4, "/tmp/project.$$.4", $flags2, 1 ],
	[ "sys ids", $file4, "/tmp/project.$$.4", $flags3, 0 ],
	[ "sys ids", $file4, "/tmp/project.$$.4", $flags4, 1 ],
	[ "unique users", $file5, "/tmp/project.$$.5", $flags1, 0 ],
	[ "unique users", $file5, "/tmp/project.$$.5", $flags2, 0 ],
	[ "unique users", $file5, "/tmp/project.$$.5", $flags3, 0 ],
	[ "unique users", $file5, "/tmp/project.$$.5", $flags4, 0 ]
);

my $projents;
my @goodprojents;
my $read_test;
my $desc;
my $file;
my $filename;
my $flags;
my $flagstring;
my $exp;
my $error;

# Do projf_read tests.
foreach $read_test (@read_tests) {

	($desc, $file, $filename, $flags, $exp) = @$read_test;
	$flagstring = hash2string($flags);
	start("projf_read(): $desc, flags: $flagstring, file: $filename");

	seek($file, 0, 0);

	($ret, $projents) = projf_read($file, $flags);
	# check return is expected result
	if ($ret != $exp) {
		fail("Expected $exp, Returned $ret");
		if ($ret) {
			foreach $error (@$projents) {
				comment("# " . join(", ", @$error));;
			}
		}
		next;
	}
	# verify either projents or error messages were returned
	if (!(@$projents)) {
		fail("Missing projents or error messages");
		next;
	}
	pass();

	# Save projents from successful reads for testing projf_write.
	if ($ret == 0) {
		push(@goodprojents, [$desc, $flags, $projents, $filename]);
	}
}

close($file1);
close($file2);
close($file3);
close($file4);
close($file5);

# Test projf_write, write each successfully read file.

my @write_tests;
my $write_test;

foreach $write_test (@goodprojents) {

	($desc, $flags, $projents, $filename) = @$write_test;
	$flagstring = hash2string($flags);
	start("projf_write(): $desc, flags: $flagstring, file: $filename");

	open($fh, ">$filename.w") || fatal($!);

	projf_write($fh, $projents);
	close($fh);
	system("cmp -s $filename $filename.w") == 0 ? pass() :
	    fail("Written file $filename.w does not match file $filename");
}

# Tests for projent_parse and projent_validate.

my @projent_tests;
my $projent_test;

#
# Tests, in format:
#
#  [ parse_result_expected, validate_result_expected, flags, project-line ]
#
@projent_tests = (
 
# positive

	[ 0, 0, { "res" => 1 }, "system:0::::" ],
	[ 0, 0, { "res" => 1 }, "user.root:1::::" ],
	[ 0, 0, { "res" => 1 }, "noproject:2::::" ],
	[ 0, 0, { "res" => 1 }, "default:3::::" ],
	[ 0, 0, { "res" => 1 }, "group.staff:10::::" ],
	[ 0, 0, {}, "long:100::::" . "a" x 2048 ],
	[ 0, 0, {}, "Validname:101::::" ],
	[ 0, 0, {}, "Validname2:102::::" ],
	[ 0, 0, {}, "valid3name:103::::" ],
	[ 0, 0, {}, "VALIDNAME:104::::" ],
	[ 0, 0, {}, "VALIDNAME5:105::::" ],
	[ 0, 0, {}, "vAlid5name:106::::" ],
	[ 0, 0, {}, "valid.name:107::::" ],
	[ 0, 0, {}, "valid8.NAME:108::::" ],
	[ 0, 0, {}, "Valid_name9:109::::" ],
	[ 0, 0, {}, "V_alid.name10:110::::" ],
	[ 0, 0, {}, "valid12345678901234567890123456789012345678901234567890123456789:111::::" ],
	[ 0, 0, {}, "projid:2147483647::::" ],
	[ 0, 0, {}, "comment:111: this is ! & my crazy	!@#$%^&*()_+|~`\=-][ 0, 0, {},}{';\"/.,?>< comment:::" ],
	[ 0, 0, {}, "user1:112::*::" ],
	[ 0, 0, {}, "user2:113::!*::" ],
	[ 0, 0, {}, "user3:114::root::" ],
	[ 0, 0, {}, "user4:115::!root::" ],
	[ 0, 0, {}, "user5:116::*,!sys::" ],
	[ 0, 0, {}, "user6:117::!*,daemon::" ],
	[ 0, 0, {}, "user7:118::root,sys,daemon,bin::" ],
	[ 0, 0, {}, "user8:119::root,!sys,daemon,!bin::" ],
	[ 0, 0, { "allowspaces" => 1 }, "user9:116::*, !sys::" ],
	[ 0, 0, { "allowspaces" => 1 }, "user10:117::!* ,daemon::" ],
	[ 0, 0, { "allowspaces" => 1 }, "user11:118::root ,sys ,daemon, bin::" ],
	[ 0, 0, { "allowspaces" => 1 }, "user12:119::root, !sys, daemon ,!bin::" ],
	[ 0, 0, {}, "group1:120:::*:" ],
	[ 0, 0, {}, "group2:121:::!*:" ],
	[ 0, 0, {}, "group3:122:::root:" ],
	[ 0, 0, {}, "group4:123:::!root:" ],
	[ 0, 0, {}, "group5:124:::*,!sys:" ],
	[ 0, 0, {}, "group6:125:::!*,daemon:" ],
	[ 0, 0, {}, "group7:126:::root,sys,daemon,bin:" ],
	[ 0, 0, {}, "group8:127:::root,!sys,daemon,!bin:" ],
	[ 0, 0, { "allowspaces" => 1 }, "group9:124:::*, !sys:" ],
	[ 0, 0, { "allowspaces" => 1 }, "group10:125:::!* ,daemon:" ],
	[ 0, 0, { "allowspaces" => 1 }, "group11:126:::root, sys ,daemon, bin:" ],
	[ 0, 0, { "allowspaces" => 1 }, "group12:127:::root ,!sys, daemon ,!bin:" ],
	[ 0, 0, {}, "group9:128:::sys:" ],
	[ 0, 0, {}, "attrib1:129::::one" ],
	[ 0, 0, {}, "attrib2:130::::One" ],
	[ 0, 0, {}, "attrib3:131::::ONE" ],
	[ 0, 0, {}, "attrib4:132::::attrib10" ],
	[ 0, 0, {}, "attrib5:133::::attrib.attrib=" ],
	[ 0, 0, {}, "attrib6:134::::attib_" ],
	[ 0, 0, {}, "attrib7:135::::a10-._attib" ],
	[ 0, 0, {}, "attrib8:136::::SUNW,attrib" ],
	[ 0, 0, {}, "attrib9:137::::A,A10=" ],
	[ 0, 0, {}, "attrib10:138::::FIVEE,name" ],
	[ 0, 0, {}, "attrib11:139::::one;two" ],
	[ 0, 0, {}, "attrib12:140::::one=1;two=four" ],
	[ 0, 0, {}, "attrib13:141::::one;two=;three=four" ],
	[ 0, 0, {}, "value1:142::::one=foo,bar" ],
	[ 0, 0, {}, "value2:143::::one=,bar," ],
	[ 0, 0, {}, "value3:144::::one=(foo,bar)" ],
	[ 0, 0, {}, "value4:145::::one=(foo,bar,baz),boo" ],
	[ 0, 0, {}, "value5:146::::one;two=bar,(baz),foo,((baz)),(,)" ],
	[ 0, 0, {}, "value6:147::::one=100/200" ],
	[ 0, 0, {}, "value7:148::::two=.-_/=" ],
	[ 0, 0, {}, "value8:149::::name=one=two" ],
	[ 0, 0, { "allowunits" => 1 }, "value9:150::::task.max-lwps=(priv,1000M,deny,signal=SIGHUP),(priv,1000k,deny,signal=SIGKILL)" ],
	[ 0, 0, {}, "comma1:151::,::" ],
	[ 0, 0, {}, "comma2:152::,,::" ],
	[ 0, 0, {}, "comma3:153::root,::" ],
	[ 0, 0, {}, "comma4:154::bin,root,,::" ],
	[ 0, 0, {}, "comma5:155:::,:" ],
	[ 0, 0, {}, "comma6:156:::,,:" ],
	[ 0, 0, {}, "comma7:157:::bin,root,:" ],
	[ 0, 0, {}, "comma8:158:::root,,:" ],
	[ 0, 0, {}, "semi1:159::::;" ],
	[ 0, 0, {}, "semi2:160::::;;" ],
	[ 0, 0, {}, "semi3:161::::foo=(one,two);" ],
	[ 0, 0, {}, "semi4:162::::foo;;" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl1:163::::task.max-lwps=(priv,1000,deny,signal=HUP),(priv,1000k,deny,signal=15)" ],
	[ 0, 0, {}, "rctl1:163::::task.max-lwps=(priv,1000,deny,signal=HUP),(priv,10001,deny,signal=15)" ],
	[ 0, 0, {}, "rctl2:164::::process.max-port-events=(basic,1000,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl3:165::::project.max-crypto-memory=(priv,2.2gb,deny)" ],
	[ 0, 0, {}, "rctl3:165::::project.max-crypto-memory=(priv,10,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl4:166::::project.max-crypto-memory=(privileged,100m,deny)" ],
	[ 0, 0, {}, "rctl4:166::::project.max-crypto-memory=(privileged,100,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl5:167::::project.max-crypto-memory=(priv,1000m,deny)" ],
	[ 0, 0, {}, "rctl5:167::::project.max-crypto-memory=(priv,1000,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl6:168::::project.max-crypto-memory=(priv,1000k,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl6:168::::project.max-crypto-memory=(priv,1000m,deny)" ],
	[ 0, 0, {}, "rctl7:169::::process.max-msg-messages=(priv,10,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl8:170::::process.max-msg-qbytes=(priv,10000kb,deny)" ],
	[ 0, 0, {}, "rctl8:170::::process.max-msg-qbytes=(priv,10000,deny)" ],
	[ 0, 0, {}, "rctl9:171::::process.max-sem-ops=(priv,10000000,deny)" ],
	[ 0, 0, {}, "rctl10:172::::process.max-sem-nsems=(basic,1,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl11:173::::process.max-address-space=(priv,2GB,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl12:174::::process.max-file-descriptor=(basic,1K,deny),(basic,2K,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl13:175::::process.max-core-size=(priv,10Mb,deny),(priv,2GB,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl14:176::::process.max-stack-size=(priv,1.8Gb,deny),(priv,100MB,deny)" ],
	[ 0, 0, {}, "rctl15:177::::process.max-data-size=(priv,1010100101,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl16:178::::process.max-file-size=(priv,100mb,deny,signal=SIGXFSZ),(priv,1000mb,deny,signal=31)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl17:179::::process.max-cpu-time=(priv,1t,signal=XCPU),(priv,100ms,sig=30)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl18:180::::task.max-cpu-time=(priv,1M,sig=SIGKILL)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl19:181::::task.max-lwps=(basic,10,signal=1),(priv,100,deny,signal=KILL)" ],
	[ 0, 0, {}, "rctl20:182::::project.max-device-locked-memory=(priv,1000,deny,sig=TERM)" ],
	[ 0, 0, {}, "rctl21:183::::project.max-port-ids=(priv,100,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl22:184::::project.max-shm-memory=(priv,1000mb,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl23:185::::project.max-shm-ids=(priv,1k,deny,signal=SIGSTOP)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl24:186::::project.max-msg-ids=(priv,1m,deny,signal=XRES)" ],
	[ 0, 0, {}, "rctl25:187::::project.max-sem-ids=(priv,10,deny,signal=ABRT)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl26:188::::project.cpu-shares=(priv,63k,none)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl27:189::::zone.cpu-shares=(priv,20k,none)" ],
	[ 0, 0, {}, "rctl28:190::::zone.cpu-shares=(priv,100,none)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl29:191::::project.max-shm-memory=(priv,200G,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl30:192::::project.max-shm-memory=(priv,200Gb,deny)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl31:193::::project.max-shm-memory=(priv,2000B,deny)" ],
	[ 0, 0, {}, "rctl32:194::::project.max-shm-memory=(priv,2000,deny)" ],
	[ 0, 0, {}, "rctl33:195::::task.max-cpu-time=(priv,2000,none)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl34:196::::task.max-cpu-time=(priv,2000s,none)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl35:197::::task.max-cpu-time=(priv,20.1ps,none)" ],
	[ 0, 0, { "allowunits" => 1 }, "rctl36:198::::task.max-cpu-time=(priv,20T,none)" ],

# negative

	[ 0, 1, {}, "system:0::::" ],
	[ 0, 1, {}, "user.root:1::::" ],
	[ 0, 1, {}, "noproject:2::::" ],
	[ 0, 1, {}, "default:3::::" ],
	[ 0, 1, {}, "group.staff:10::::" ],
	[ 0, 1, {}, "long:100::::" . "a" x 4096 ],
	[ 1, 0, {}, "extrafields:101:::::" ],
	[ 1, 0, {}, "missingfields:102:::" ],
	[ 1, 0, {}, "_invalidname:103::::" ],
	[ 1, 0, {}, "10invlidname:104::::" ],
	[ 1, 0, {}, "invalid%name:105::::" ],
	[ 1, 0, {}, "invalid/name:106::::" ],
	[ 1, 0, {}, ".invalidname:107::::" ],
	[ 1, 0, {}, "=invalidName:108::::" ],
	[ 1, 0, {}, "invalid=name:109::::" ],
	[ 1, 0, {}, "invalid/name:110::::" ],
	[ 1, 0, {}, "/invalidname:111::::" ],
	[ 1, 0, {}, "/invalidname:112::::" ],
	[ 1, 0, {}, "invalidname*:113::::" ],
	[ 1, 0, {}, "invalid?name:114::::" ],
	[ 1, 0, {}, ":115:invalid name comment:::" ],
	[ 1, 0, {}, "invalid!name:116::::" ],
	[ 1, 0, {}, "invalidname!:117::::" ],
	[ 1, 0, {}, "invalid12345678901234567890123456789012345678901234567890123456789:118::::" ],
	[ 1, 0, {}, "projid:-1::::" ],
	[ 1, 0, {}, "projid:abc::::" ],
	[ 1, 0, {}, "projid:2147483648::::" ],
	[ 1, 0, {}, "projid:::::" ],
	[ 1, 0, {}, "user1:118::*!::" ],
	[ 1, 0, {}, "user2:119::10user::" ],
	[ 0, 1, {}, "user3:120::NOLOWER::" ],
	[ 0, 1, {}, "user4:121::toooolong::" ],
	[ 1, 0, {}, "user5:122::root!::" ],
	[ 1, 0, {}, "user6:123::root;sys::" ],
	[ 0, 1, {}, "user7:124::sys,NOLOWER::" ],
	[ 1, 0, {}, "user8:125::sys/bin,root::" ],
	[ 1, 0, {}, "user9:116::*, !sys::" ],
	[ 1, 0, {}, "user10:117::!* ,daemon::" ],
	[ 1, 0, {}, "user11:118::root ,sys ,daemon, bin::" ],
	[ 1, 0, {}, "user12:119::root, !sys, daemon ,!bin::" ],
	[ 1, 0, {}, "group1:126:::*!:" ],
	[ 0, 1, {}, "group2:127:::oneUpper:" ],
	[ 0, 1, {}, "group3:128:::NOLOWER:" ],
	[ 0, 1, {}, "group4:129:::toooolong:" ],
	[ 1, 0, {}, "group5:130:::root!:" ],
	[ 1, 0, {}, "group6:131:::root;sys:" ],
	[ 0, 1, {}, "group7:132:::sys,NOLOWER:" ],
	[ 1, 0, {}, "group8:133:::sys-bin,root:" ],
	[ 1, 0, {}, "group9:124:::*, !sys:" ],
	[ 1, 0, {}, "group10:125:::!* ,daemon:" ],
	[ 1, 0, {}, "group11:126:::root, sys ,daemon, bin:" ],
	[ 1, 0, {}, "group12:127:::root ,!sys, daemon ,!bin:" ],
	[ 1, 0, {}, "attrib1:134::::10" ],
	[ 1, 0, {}, "attrib2:135::::_foo=" ],
	[ 1, 0, {}, "attrib3:136::::,foo" ],
	[ 1, 0, {}, "attrib4:137::::sun,foo" ],
	[ 1, 0, {}, "attrib6:139::::!attrib" ],
	[ 1, 0, {}, "attrib7:140::::_attrib" ],
	[ 1, 0, {}, "attrib8:141::::attib,attrib" ],
	[ 1, 0, {}, "attrib9:142::::attrib/attrib" ],
	[ 1, 0, {}, "attrib10:143::::one;two,three" ],
	[ 1, 0, {}, "attrib11:144::::one=two;three/" ],
	[ 1, 0, {}, "value1:145::::one=foo%" ],
	[ 1, 0, {}, "value2:146::::one= two" ],
	[ 1, 0, {}, "value3:147::::var=foo?" ],
	[ 1, 0, {}, "value4:148::::name=value;name=value2)" ],
	[ 1, 0, {}, "value5:149::::(foo)" ],
	[ 1, 0, {}, "value6:150::::name=(foo,bar" ],
	[ 1, 0, {}, "value7:151::::name=(value)(value)" ],
	[ 1, 0, {}, "value8:152::::name=)" ],
	[ 1, 0, {}, "value9:153::::name=value,(value value)" ],
	[ 1, 0, {}, "value10:154::::name=(value(value))" ],
	[ 1, 0, {}, "value11:155::::name=(value)value" ],
	[ 1, 0, {}, "value11:156::::name=va?lue" ],
	[ 1, 0, {}, "value12:157::::name=(value,value))" ],
	[ 1, 0, {}, "value13:158::::name=(value),value)" ],
	[ 1, 0, {}, "space1 :159::::" ],
	[ 1, 0, {}, " space2:160::::" ],
	[ 1, 0, {}, "space3: 161::::" ],
	[ 1, 0, {}, "space4:162 ::::" ],
	[ 1, 0, {}, "space 5:163::::" ],
	[ 1, 0, {}, "space6:1 64::::" ],
	[ 1, 0, {}, "space7:165:: root::" ],
	[ 1, 0, {}, "space8:166::root ::" ],
	[ 1, 0, {}, "space9:167::daemon, root::" ],
	[ 1, 0, {}, "space10:168::bin root::" ],
	[ 1, 0, {}, "space11:169::daemon ,root::" ],
	[ 1, 0, {}, "space12 :170::::" ],
	[ 1, 0, {}, " space13:171::::" ],
	[ 1, 0, {}, "space14: 172::::" ],
	[ 1, 0, {}, "space15:173 ::::" ],
	[ 1, 0, {}, "space 16:174::::" ],
	[ 1, 0, {}, "space17:1 75::::" ],
	[ 1, 0, {}, "space18:176::: root:" ],
	[ 1, 0, {}, "space19:177:::root :" ],
	[ 1, 0, {}, "space20:178:::daemon, root:" ],
	[ 1, 0, {}, "space21:179:::bin root:" ],
	[ 1, 0, {}, "space22:180:::daemon ,root:" ],
	[ 1, 0, {}, "space23:181:::: foo" ],
	[ 1, 0, {}, "space34:182::::foo =one" ],
	[ 1, 0, {}, "space35:183::::foo= (one)" ],
	[ 1, 0, {}, "space36:184::::foo=(one, two)" ],
	[ 1, 0, {}, "space37:185::::foo=(one ,two)" ],
	[ 1, 0, {}, "space38:186::::foo=( one)" ],
	[ 1, 0, {}, "space39:187::::foo=(one )" ],
	[ 1, 0, {}, "space40:188::::foo=(one) ,two" ],
	[ 1, 0, {}, "space41:189::::foo=one, (two)" ],
	[ 1, 0, {}, "comma1:190::,root,bin::" ],
	[ 1, 0, {}, "comma2:191::root,,bin::" ],
	[ 1, 0, {}, "comma3:192::,,root,bin::" ],
	[ 1, 0, {}, "comma4:193:::,root,bin:" ],
	[ 1, 0, {}, "comma5:194:::root,,bin:" ],
	[ 1, 0, {}, "comma6:195:::,,root,bin:" ],
	[ 1, 0, {}, "semi1:196::::;foo" ],
	[ 1, 0, {}, "semi2:197::::foo;;bar=1" ],
	[ 1, 0, {}, "semi3:198::::;;bar=(10)" ],
	[ 0, 1, {}, "rctl1:199::::task.max-lwps=," ],
	[ 0, 1, {}, "rctl2:200::::task.max-lwps=" ],
	[ 0, 1, {}, "rctl3:201::::task.max-lwps=priv" ],
	[ 0, 1, {}, "rctl4:202::::task.max-lwps=priv,1000" ],
	[ 0, 1, {}, "rctl5:203::::task.max-lwps=priv,1000,deny" ],
	[ 0, 1, {}, "rctl6:204::::task.max-lwps=(priv)" ],
	[ 0, 1, {}, "rctl7:205::::task.max-lwps=(priv,1000)" ],
	[ 0, 1, {}, "rctl8:206::::task.max-lwps=(foo,100,deny)" ],
	[ 0, 1, {}, "rctl9:207::::task.max-lwps=(priv,foo,none)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl9:207::::task.max-lwps=(priv,foo,none)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl10:208::::task.max-lwps=(priv,100foo,none)" ],
	[ 0, 1, {}, "rctl11:209::::task.max-lwps=(priv,1000,foo)" ],
	[ 0, 1, { "allowunits" => 1 }, "rctl12:210::::task.max-lwps=(priv,1000k,deny,signal)" ],
	[ 0, 1, {}, "rctl13:211::::task.max-lwps=(priv,1000,deny,signal=)" ],
	[ 0, 1, {}, "rctl14:212::::task.max-lwps=(priv,1000,deny,signal=foo)" ],
	[ 0, 1, {}, "rctl15:213::::task.max-lwps=(priv,1000,deny,signal=1fo)" ],
	[ 0, 1, {}, "rctl16:214::::task.max-lwps=(priv,1000,deny,signal=100)" ],
	[ 0, 1, {}, "rctl17:215::::task.max-lwps=(priv,1000,deny,signal=SIG)" ],
	[ 0, 1, {}, "rctl18:216::::task.max-lwps=(priv,1000,deny,signal=SIG1)" ],
	[ 0, 1, {}, "rctl19:217::::task.max-lwps=(priv,1000,deny,signal=SIGhup)" ],
	[ 0, 1, {}, "rctl20:218::::task.max-lwps=(priv,1000,deny,signal=SIGHU)" ],
	[ 0, 1, {}, "rctl21:219::::task.max-lwps=(priv,1000,deny,signal=SIGHUPP)" ],
	[ 0, 1, {}, "rctl22:220::::task.max-lwps=(priv,1000,deny,signal=SIGURG)" ],
	[ 0, 1, {}, "rctl23:221::::task.max-lwps=(priv,1000,deny,signal=SIGXCPU)" ],
	[ 0, 1, {}, "rctl24:222::::task.max-lwps=(priv,1000,deny,signal=SIGKILL,10)" ],
	[ 0, 1, {}, "rctl25:223::::task.max-lwps=(priv,1000,deny,signal=SIGKILL,foo)" ],
	[ 0, 1, {}, "rctl26:224::::process.max-port-events=(priv,1000,none)" ],
	[ 0, 1, { "allowunits" => 1 }, "rctl27:225::::process.max-address-space=(basic,1024mb,deny,signal=TERM)" ],
	[ 0, 1, {}, "rctl28:226::::process.max-cpu-time=(basic,3600,deny)" ],
	[ 0, 1, {}, "rctl29:227::::task.max-lwps=()" ],
	[ 0, 1, {}, "rctl30:228::::task.max-lwps=((priv),deny)" ],
	[ 0, 1, {}, "rctl31:229::::task.max-lwps=((priv,1000,deny))" ],
	[ 0, 1, {}, "rctl32:230::::task.max-lwps=(priv,((1000,2000,1000)),deny)" ],
	[ 0, 1, {}, "rctl33:231::::task.max-lwps=(,,,)" ],
	[ 0, 1, {}, "rctl34:232::::task.max-lwps=(priv,1000,(deny))" ],
	[ 0, 1, {}, "rctl35:233::::task.max-lwps=(priv,1000,deny),foo" ],
	[ 0, 1, {}, "rctl36:234::::task.max-lwps=(priv,1000,deny),(priv,1000)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl37:235::::project.max-msg-ids=(priv,15EB,deny)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl38:236::::process.max-address-space=(priv,16.1EB,deny)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl39:237::::process.max-address-space=(priv,18000000000gb,deny)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl40:238::::zone.cpu-shares=(priv,10kb,none)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl41:239::::zone.cpu-shares=(priv,10Ks,none)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl42:240::::zone.cpu-shares=(priv,10s,none)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl43:241::::zone.cpu-shares=(priv,100000b,none)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl44:242::::project.max-shm-memory=(priv,200Ts,deny)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl45:243::::project.max-shm-memory=(priv,200s,deny)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl46:244::::task.max-cpu-time=(priv,20B,none)" ],
	[ 1, 0, { "allowunits" => 1 }, "rctl47:245::::task.max-cpu-time=(priv,20Kb,none)" ],
	[ 0, 1, { "allowunits" => 1 }, "rctl48:246::::project.cpu-shares=(priv,100k,none)" ],
	[ 0, 1, {}, "rctl147:150::::task.max-lwps=(priv,1000M,deny,signal=SIGHUP),(priv,1000k,deny,signal=SIGKILL)" ],
	[ 0, 1, {}, "rctl148:163::::task.max-lwps=(priv,1000,deny,signal=HUP),(priv,1000k,deny,signal=15)" ],
	[ 0, 1, {}, "rctl3:165::::project.max-crypto-memory=(priv,10eb,deny)" ],
	[ 0, 1, {}, "rctl4:166::::project.max-crypto-memory=(privileged,100p,deny)" ],
	[ 0, 1, {}, "rctl5:167::::project.max-crypto-memory=(priv,1000t,deny)" ],
	[ 0, 1, {}, "rctl6:168::::project.max-crypto-memory=(priv,1000g,deny)" ],
	[ 0, 1, {}, "rctl7:169::::process.max-msg-messages=(priv,10m,deny)" ],
	[ 0, 1, {}, "rctl8:170::::process.max-msg-qbytes=(priv,10000kb,deny)" ],
	[ 0, 1, {}, "rctl11:173::::process.max-address-space=(priv,10EB,deny)" ],
	[ 0, 1, {}, "rctl12:174::::process.max-file-descriptor=(basic,1K,deny),(basic,2K,deny)" ],
	[ 0, 1, {}, "rctl13:175::::process.max-core-size=(priv,1Eb,deny),(priv,10PB,deny)" ],
	[ 0, 1, {}, "rctl14:176::::process.max-stack-size=(priv,10Tb,deny),(priv,10TB,deny)" ],
	[ 0, 1, {}, "rctl16:178::::process.max-file-size=(priv,100mb,deny,signal=SIGXFSZ),(priv,1000mb,deny,signal=31)" ],
	[ 0, 1, {}, "rctl17:179::::process.max-cpu-time=(priv,1t,signal=XCPU),(priv,100ms,sig=30)" ],
	[ 0, 1, {}, "rctl18:180::::task.max-cpu-time=(priv,1M,sig=SIGKILL)" ],
	[ 0, 1, {}, "rctl22:184::::project.max-shm-memory=(priv,1000mb,deny)" ],
	[ 0, 1, {}, "rctl23:185::::project.max-shm-ids=(priv,1k,deny,signal=SIGSTOP)" ],
	[ 0, 1, {}, "rctl24:186::::project.max-msg-ids=(priv,1m,deny,signal=XRES)" ],
	[ 0, 1, {}, "rctl26:188::::project.cpu-shares=(priv,63k,none)" ],
	[ 0, 1, {}, "rctl27:189::::zone.cpu-shares=(priv,20k,none)" ],
	[ 0, 1, {}, "rctl29:191::::project.max-shm-memory=(priv,200G,deny)" ],
	[ 0, 1, {}, "rctl30:192::::project.max-shm-memory=(priv,200Gb,deny)" ],
	[ 0, 1, {}, "rctl31:193::::project.max-shm-memory=(priv,2000B,deny)" ],
	[ 0, 1, {}, "rctl34:196::::task.max-cpu-time=(priv,2000s,none)" ],
	[ 0, 1, {}, "rctl35:197::::task.max-cpu-time=(priv,20.1ps,none)" ],
	[ 0, 1, {}, "rctl36:198::::task.max-cpu-time=(priv,20T,none)" ],
);

my $parse_exp;
my $parse_ret;
my $validate_exp;
my $validate_ret;
my $project;
my $projent;
my $errors;

foreach $projent_test ( @projent_tests) {

	($parse_exp, $validate_exp, $flags, $project) = @$projent_test;
	$flagstring = hash2string($flags);	
	start("projent_parse(): flags: $flagstring, project: $project"); 
	($ret, $projent) = projent_parse($project, $flags);
	if ($ret != $parse_exp) {
		fail("Expected $parse_exp, Returned $ret");
		if ($ret) {
			foreach $error (@$projent) {
				comment("# " . join(", ", @$error));
			}	
		}
		next;
	}
	pass();

	# projent_validate() can only be successfully parsed projents
	if ($ret) {
		next;
	}

	start("projent_validate():  flags: $flagstring, project: $project");
	($ret, $errors) = projent_validate($projent, $flags);
	if ($ret != $validate_exp) {
		fail("Expected $validate_exp, Returned $ret");
		if ($ret) {
			foreach $error (@$errors) {
				comment("# " . join(", ", @$error));
			}	
		}
		next;
	}
	pass();
}

my $pf1;
my $pf2;
my $fh1;
my $fh2;
my @lines;

# get projects and make local copy
open($fh1, "/usr/bin/getent project |") || fatal($!);
open($fh2, ">/tmp/projent.$$") || fatal($!);
@lines = <$fh1>;
print $fh2 @lines;
close($fh1);
close($fh2);

open($fh1, "</tmp/projent.$$") || fatal($!);
$pf1 = read_pfile($fh1);
close($fh1);


start("Test getprojid");
($s) = `/usr/xpg4/bin/id -p` =~ /projid=(\d+)/;
defined($s) && $s == getprojid() ? pass() : fail();

start("Test fgetprojent");
$pf2 = [];
open($fh, "</tmp/projent.$$") || fatal($!);
while (my @proj = fgetprojent($fh)) {
	push(@$pf2, [ @proj ]);
}
close($fh);
cmp_recs($pf1, $pf2) ? pass() : fail();

my %pf_byname = map({ $_->[0] => $_} @$pf1);
my %pf_byid = map({ $_->[1] => $_} @$pf1);
my (%h, @a1, @a2, $k, $v);

start("Test getprojent.  Don't assume anything about the order it returns stuff in");
%h = %pf_byname;
$pass = 1;
@a2 = ();
while (@a1 = getprojent()) {
	@a2 = @a1 if (! scalar(@a2));
	if (exists($h{$a1[0]})) {
		$pass = 0 if (! cmp_recs(\@a1, $h{$a1[0]}));
		delete($h{$a1[0]});
	} else {
		$pass = 0;
	}
}
$pass && ! %h ? pass() : fail();

start("Test getprojent when at end");
@a1 = getprojent();
cmp_recs(\@a1, []) ? pass() : fail();


start("Test endprojent/getprojent");
endprojent();
@a1 = getprojent();
cmp_recs(\@a1, \@a2) ? pass() : fail();

start("Test setprojent/getprojent");
setprojent();
@a1 = getprojent();
cmp_recs(\@a1, \@a2) ? pass() : fail();
setprojent();

start("Test getprojbyname");
$pass = 1;
while (($k, $v) = each(%pf_byname)) {
	@a1 = getprojbyname($k);
	$pass = 0 if (! cmp_recs(\@a1, $v));
}
$pass ? pass() : fail();

start("Test getprojbyid");
$pass = 1;
while (($k, $v) = each(%pf_byid)) {
	@a1 = getprojbyid($k);
	$pass = 0 if (! cmp_recs(\@a1, $v));
}
$pass ? pass() : fail();

start("Test getprojidbyname");
$pass = 1;
while (($k, $v) = each(%pf_byname)) {
	$pass = 0 if (getprojidbyname($k) != $v->[1]);
}
$pass ? pass() : fail();

start("Test getdefaultproj");
my $username = getpwuid($>);
my $projid; 
$s = `/bin/id -p` ;
($projid) = $s =~ /projid=\d+\(([^)]+)\)/;
defined($projid) && $projid eq getdefaultproj($username) ? pass() : fail();

start("test inproj");
$s = `/usr/bin/projects`;
($s) = split(/\s+/, $s);
inproj($username, $s) ? pass() : fail();

exit(0);
#
# Copyright (c) 2000, 2008, Oracle and/or its affiliates. All rights reserved.
#

TYPEMAP
	projid_t	T_IV
	const char *	T_PV
	uint_t		T_UV

INPUT

OUTPUT

#
# Copyright (c) 2003, Oracle and/or its affiliates. All rights reserved.
#

Version 1.2
Initial Public Source release.
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

include $(SRC)/Makefile.master

SUBDIRS = $(MACH64)

all :		TARGET = all
install :	TARGET = install
clean :	TARGET = clean
clobber :	TARGET = clobber

all install clean clobber: $(SUBDIRS)

$(SUBDIRS): FRC
	@cd $@; pwd; $(MAKE) $(TARGET)

FRC:
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = Task

include $(SRC)/cmd/perl/Makefile.perl

XSUBPPFLAGS = -typemap typemap

MAPFILES = ../mapfile-vers
#
# Copyright (c) 2003, Oracle and/or its affiliates. All rights reserved.
#

Licensing
---------
This module is released under the Perl Artistic License.

Availability
------------
This module is only available for Solaris 9 onwards.

Description
-----------
This module provided access to the Solaris Task subsystem, which is part of
the Solaris resource management infrastructure.

For more information on Solaris Tasks, see the project(5) manpage and the
following on-line documentation:

System Administration Guide: Resource Management and Network Services
Chapter 6 - Projects and Tasks
http://docs.sun.com/db/doc/816-7125

Installation
------------

1. Uncompress and untar the archive
2. cd to the module directory
3. perl Makefile.PL; make install

If you are using gcc and wish to build this module against the perl shipped as
part of Solaris, see the Solaris-PerlGcc module, also available from CPAN.
#
# Copyright (c) 2003, Oracle and/or its affiliates. All rights reserved.
#

This module is released as Public Source via the Comprehensive Perl Archive
Network (http://www.cpan.org).  If it is updated for any reason, a new
release should be pushed to CPAN.

The version number of this module is derived from the $VERSION variable in
Task.pm.  If anything under this directory is modified, $VERSION should be 
changed in Task.pm to update the module version number correctly.  If this 
is not done, it will not be possible to upload the generated archive to CPAN, 
as CPAN requires that uploaded archives have unique names.

To prepare the contents of the directory for release, they should be packaged
up as a .tar.gz archive.  The procedure for this is:

$ /usr/perl5/bin/perl Makefile.PL
$ make tardist

This will produce the file for upload to CPAN.  Contact cpan-support@sun.com
for details of how to do this.
#
# Copyright (c) 2002, 2008, Oracle and/or its affiliates. All rights reserved.
# Copyright (c) 2014 Racktop Systems.
#

#
# Task.pm provides the bootstrap for the Sun::Solaris::Task module.
#

require 5.0010;
use strict;
use warnings;

package Sun::Solaris::Task;

our $VERSION = '1.4';
use XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);

our (@EXPORT_OK, %EXPORT_TAGS);
my @constants = qw(TASK_NORMAL TASK_FINAL TASK_PROJ_PURGE);
my @syscalls = qw(settaskid gettaskid);
@EXPORT_OK = (@constants, @syscalls);
%EXPORT_TAGS = (CONSTANTS => \@constants, SYSCALLS => \@syscalls,
    ALL => \@EXPORT_OK);

use base qw(Exporter);

1;
/*
 * Copyright (c) 2002, 2007, Oracle and/or its affiliates. All rights reserved.
 */
/*
 * Task.xs contains XS wrappers for the task maniplulation functions.
 */

/* Solaris includes. */
#include <sys/task.h>

/* Perl includes. */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/*
 * The XS code exported to perl is below here.  Note that the XS preprocessor
 * has its own commenting syntax, so all comments from this point on are in
 * that form.
 */

MODULE = Sun::Solaris::Task PACKAGE = Sun::Solaris::Task
PROTOTYPES: ENABLE

 #
 # Define any constants that need to be exported.  By doing it this way we can
 # avoid the overhead of using the DynaLoader package, and in addition constants
 # defined using this mechanism are eligible for inlining by the perl
 # interpreter at compile time.
 #
BOOT:
	{
	HV *stash;

	stash = gv_stashpv("Sun::Solaris::Task", TRUE);
	newCONSTSUB(stash, "TASK_NORMAL", newSViv(TASK_NORMAL));
	newCONSTSUB(stash, "TASK_FINAL", newSViv(TASK_FINAL));
	newCONSTSUB(stash, "TASK_PROJ_PURGE", newSViv(TASK_PROJ_PURGE));
	}

taskid_t
settaskid(project, flags)
	projid_t	project
	int		flags

taskid_t
gettaskid()

#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#

# Copyright 2022, Richard Lowe.

include ../Makefile.com
include $(SRC)/cmd/perl/Makefile.perl.64

all: $(PERLEXT)
install: $(ROOTPERLEXT) $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright (c) 2014 Racktop Systems.
#

$mapfile_version 2

SYMBOL_SCOPE {
    global:
	boot_Sun__Solaris__Task;
	XS_Sun__Solaris__Task_gettaskid;
	XS_Sun__Solaris__Task_settaskid;
    local:
	*;
};
#
# Copyright (c) 2002, 2003, Oracle and/or its affiliates. All rights reserved.
#

#
# Sun::Solaris::Task documentation.
# 

=head1 NAME

Sun::Solaris::Task - Perl interface to Tasks

=head1 SYNOPSIS

 use Sun::Solaris::Task qw(:ALL);
 my $taskid = gettaskid();

This module provides wrappers for the C<gettaskid(2)> and C<settaskid(2)>
system calls.

=head2 Constants

C<TASK_NORMAL>, C<TASK_FINAL>.

=head2 Functions

B<C<settaskid($project, $flags)>>

The C<$project> parameter must be a valid project ID and the C<$flags>
parameter must be C<TASK_NORMAL> or C<TASK_FINAL>. The parameters are passed
through directly to the underlying C<settaskid()> system call. The new task ID
is returned if the call succeeds. On failure -1 is returned.

C<gettaskid()>

This function returns the numeric task ID of the calling process, or C<undef>
if the underlying C<gettaskid()> system call is unsuccessful.

=head2 Class methods

None.

=head2 Object methods

None.

=head2 Exports

By default nothing is exported from this module. The following tags can be
used to selectively import constants and functions defined in this module:

 :SYSCALLS    settaskid() and gettaskid()

 :CONSTANTS   TASK_NORMAL and TASK_FINAL

 :ALL         :SYSCALLS and :CONSTANTS

=head1 ATTRIBUTES

See C<attributes(7)> for descriptions of the following attributes:

  ___________________________________________________________
 |       ATTRIBUTE TYPE        |       ATTRIBUTE VALUE       |
 |_____________________________|_____________________________|
 | Availability                | CPAN (http://www.cpan.org)  |
 |_____________________________|_____________________________|
 | Interface Stability         | Evolving                    |
 |_____________________________|_____________________________|

=head1 SEE ALSO

C<gettaskid(2)>, C<settaskid(2)>, C<attributes(7)>
#
# Copyright (c) 2002, Oracle and/or its affiliates. All rights reserved.
#

TYPEMAP
	taskid_t	T_IV
	projid_t	T_IV

INPUT

OUTPUT

#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

include $(SRC)/Makefile.master

SUBDIRS = $(MACH64)

all :		TARGET = all
install :	TARGET = install
clean :	TARGET = clean
clobber :	TARGET = clobber

all install clean clobber: $(SUBDIRS)

$(SUBDIRS): FRC
	@cd $@; pwd; $(MAKE) $(TARGET)

FRC:
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright 2014, OmniTI Computer Consulting, Inc. All rights reserved.
# Copyright 2016 RackTop Systems.
#

MODULE = Utils

include $(SRC)/cmd/perl/Makefile.perl

LDLIBS += -lgen -lintl

MAPFILES = ../mapfile-vers
#
# 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 2006 Sun Microsystems, Inc.  All rights reserved.
# Use is subject to license terms.
#

#
# Utils.pm provides the bootstrap for the Sun::Solaris::Utils module.
#

package Sun::Solaris::Utils;
use strict;
use Exporter;
use DynaLoader;
use vars qw($VERSION @ISA @EXPORT_OK);
$VERSION = '1.3';
@ISA = qw(Exporter DynaLoader);
@EXPORT_OK = qw(gmatch gettext textdomain bindtextdomain dcgettext dgettext);
bootstrap Sun::Solaris::Utils $VERSION;
1;
/*
 * 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 (c) 1999 by Sun Microsystems, Inc.
 * All rights reserved.
 */

/*
 * Utils.xs contains XS wrappers for utility functions needed initially by
 * Sun::Solaris::Kstat, but that should prove generally useful as well.
 */

/* Solaris includes */
#include <libgen.h>
#include <libintl.h>

/* Perl XS includes */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/*
 * The XS code exported to perl is below here.  Note that the XS preprocessor
 * has its own commenting syntax, so all comments from this point on are in
 * that form.
 */

MODULE = Sun::Solaris::Utils PACKAGE = Sun::Solaris::Utils
PROTOTYPES: ENABLE

 #
 # See gmatch(3GEN)
 #

int
gmatch(str, pattern)
	char *str;
	char *pattern;

 #
 # See gettext(3C)
 #

char *
gettext(msgid)
	char *msgid

 #
 # See dcgettext(3C)
 #

char *
dcgettext(domainname, msgid, category)
	char *domainname
	char *msgid
	int  category

 #
 # See dgettext(3C)
 #

char *
dgettext(domainname, msgid)
	char *domainname
	char *msgid

 #
 # See textdomain(3C)
 #

char *
textdomain(domain)
	char *domain

 #
 # See bindtextdomain(3C)
 #

char *
bindtextdomain(domain, dirname)
	char *domain
	char *dirname
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#

# Copyright 2022, Richard Lowe.

include ../Makefile.com
include $(SRC)/cmd/perl/Makefile.perl.64

all: $(PERLEXT)
install: $(ROOTPERLEXT) $(ROOTPERLMOD)

include $(SRC)/cmd/perl/Makefile.targ
#
# This file and its contents are supplied under the terms of the
# Common Development and Distribution License ("CDDL"), version 1.0.
# You may only use this file in accordance with the terms of version
# 1.0 of the CDDL.
#
# A full copy of the text of the CDDL should have accompanied this
# source.  A copy of the CDDL is also available via the Internet at
# http://www.illumos.org/license/CDDL.
#
#
# Copyright (c) 2014 Racktop Systems.
#

$mapfile_version 2

SYMBOL_SCOPE {
    global:
	boot_Sun__Solaris__Utils;
	XS_Sun__Solaris__Utils_bindtextdomain;
	XS_Sun__Solaris__Utils_dcgettext;
	XS_Sun__Solaris__Utils_dgettext;
	XS_Sun__Solaris__Utils_gettext;
	XS_Sun__Solaris__Utils_gmatch;
	XS_Sun__Solaris__Utils_textdomain;
    local:
	*;
};
#
# 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
#
#ident	"%Z%%M%	%I%	%E% SMI"
#
# test script for Sun::Solaris::Utils gmatch()
#

use strict;

BEGIN { $| = 1; print "1..49\n"; }
my $loaded;
END {print "not ok 1\n" unless $loaded;}
use Sun::Solaris::Utils qw(gmatch);
$loaded = 1;
print "ok 1\n";

my ($test);
$test = 2;

my @strs = ( 'a', 'aa', 'z', 'zz', '0', '0123456789' );
my @tests = (
    { pattern => 'a',       results => [ 1, 0, 0, 0, 0, 0 ] }, 
    { pattern => '*',       results => [ 1, 1, 1, 1, 1, 1 ] }, 
    { pattern => '?',       results => [ 1, 0, 1, 0, 1, 0 ] }, 
    { pattern => '??',      results => [ 0, 1, 0, 1, 0, 0 ] }, 
    { pattern => '[a-z]*',  results => [ 1, 1, 1, 1, 0, 0 ] }, 
    { pattern => '[!a-z]*', results => [ 0, 0, 0, 0, 1, 1 ] }, 
    { pattern => '[0-9]*',  results => [ 0, 0, 0, 0, 1, 1 ] }, 
    { pattern => '[!0-9]*', results => [ 1, 1, 1, 1, 0, 0 ] }, 
);

foreach my $t (@tests) {
	for (my $i = 0; $i < @strs; $i++) {
		if (gmatch($strs[$i], $t->{pattern}) == $t->{results}[$i]) {
			print("ok $test\n");
		} else {
			print("not ok $test\n");
		}
		$test++;
	}
}

exit(0);