xref: /onnv-gate/usr/src/cmd/perl/contrib/Sun/Solaris/Exacct/Object/Object.pm (revision 12388:1bc8d55b0dfd)

#
# Copyright (c) 2002, 2008, Oracle and/or its affiliates. All rights reserved.
#

#
# Object.pm contains perl code for exacct object manipulation.
#

require 5.8.4;
use strict;
use warnings;

package Sun::Solaris::Exacct::Object;

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

our (@EXPORT_OK, %EXPORT_TAGS, @_Constants);
@EXPORT_OK = @_Constants;
%EXPORT_TAGS = (CONSTANTS => \@_Constants, ALL => \@EXPORT_OK);

use base qw(Exporter);
use Sun::Solaris::Exacct::Catalog qw(:CONSTANTS);

#
# Class methods
#

#
# Dump an exacct object to the specified filehandle, or STDOUT by default.
#
sub dump
{
	# Fettle parameters.
	my ($class, $obj, $fh, $indent) = @_;
	$fh ||= \*STDOUT;
	$indent ||= 0;
	my $istr = '  ' x $indent;

	# Check for undef values.
	if (! defined($obj)) {
		print $fh ($istr, "UNDEFINED_VALUE\n");
		return;
	}

	# Deal with items.
	my @cat = $obj->catalog()->value();
	if ($obj->type() == &EO_ITEM) {
		printf $fh ("%sITEM\n%s  Catalog = %s|%s|%s\n",
		   $istr, $istr, @cat);
		$indent++;
		my $val = $obj->value();

		# Recursively dump nested objects.
		if (ref($val)) {
			$class->dump($val, $fh, $indent);

		# Just print out items.
		} else {
			$val = unpack('H*', $val) if ($cat[0] == &EXT_RAW);
			printf $fh ("%s  Value = %s\n", $istr, $val);
		}

	# Deal with groups.
	} else {
		printf $fh ("%sGROUP\n%s  Catalog = %s|%s|%s\n",
		    $istr, $istr, @cat);
		$indent++;
		foreach my $val ($obj->value()) {
			$class->dump($val, $fh, $indent);
		}
		printf $fh ("%sENDGROUP\n", $istr);
	}
}

#
# Item subclass - establish inheritance.
#
package Sun::Solaris::Exacct::Object::Item;
use base qw(Sun::Solaris::Exacct::Object);

#
# Group subclass - establish inheritance.
#
package Sun::Solaris::Exacct::Object::Group;
use base qw(Sun::Solaris::Exacct::Object);

#
# Tied array used for holding a group's items.
#
package Sun::Solaris::Exacct::Object::_Array;
use Carp;

#
# Check the passed list of arguments are derived from ::Object
#
sub check_args
{
	my @duff;
	foreach my $i (@_) {
		push(@duff, $i)
		    if (! UNIVERSAL::isa($i, 'Sun::Solaris::Exacct::Object'));
	}
	if (@duff) {
		local $Carp::CarpLevel = 2;
		croak('"', join('", "', @duff), @duff == 1 ? '" is' : '" are',
		    ' not of type Sun::Solaris::Exacct::Object');
	}
}

#
# Tied hash access methods
#
sub TIEARRAY
{
	return(bless([], $_[0]));
}

sub FETCHSIZE
{
	return(scalar(@{$_[0]}));
}

sub STORESIZE
{
	$#{$_[0]} = $_[1] - 1;
}

sub STORE
{
	check_args($_[2]);
	return($_[0]->[$_[1]] = copy_xs_ea_objects($_[2]));
}

sub FETCH
{
	return($_[0]->[$_[1]]);
}

sub CLEAR
{
	@{$_[0]} = ();
}

sub POP
{
	return(pop(@{$_[0]}));
}

sub PUSH
{
	my $a = shift(@_);
	check_args(@_);
	push(@$a, copy_xs_ea_objects(@_));
}

sub SHIFT
{
	return(shift(@{$_[0]}));
}

sub UNSHIFT
{
	my $a = shift(@_);
	check_args($_[2]);
	return(unshift(@$a, copy_xs_ea_objects(@_)));
}

sub EXISTS
{
	return(exists($_[0]->[$_[1]]));
}

sub DELETE
{
	return(delete($_[0]->[$_[1]]));
}

sub EXTEND
{
}

sub SPLICE
{
	my $a = shift(@_);
 	my $sz = scalar(@$a);
	my $off = @_ ? shift(@_) : 0;
	$off += $sz if $off < 0;
	my $len = @_ ? shift : $sz - $off;
	check_args(@_);
	return(splice(@$a, $off, $len, copy_xs_ea_objects(@_)));
}

1;