1# 2# CDDL HEADER START 3# 4# The contents of this file are subject to the terms of the 5# Common Development and Distribution License (the "License"). 6# You may not use this file except in compliance with the License. 7# 8# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE 9# or http://www.opensolaris.org/os/licensing. 10# See the License for the specific language governing permissions 11# and limitations under the License. 12# 13# When distributing Covered Code, include this CDDL HEADER in each 14# file and include the License file at usr/src/OPENSOLARIS.LICENSE. 15# If applicable, add the following below this CDDL HEADER, with the 16# fields enclosed by brackets "[]" replaced with your own identifying 17# information: Portions Copyright [yyyy] [name of copyright owner] 18# 19# CDDL HEADER END 20# 21# Copyright 2002-2003 Sun Microsystems, Inc. All rights reserved. 22# Use is subject to license terms. 23# 24 25# 26# Object.pm contains perl code for exacct object manipulation. 27# 28 29require 5.6.1; 30use strict; 31use warnings; 32 33package Sun::Solaris::Exacct::Object; 34 35our $VERSION = '1.3'; 36use XSLoader; 37XSLoader::load(__PACKAGE__, $VERSION); 38 39our (@EXPORT_OK, %EXPORT_TAGS, @_Constants); 40@EXPORT_OK = @_Constants; 41%EXPORT_TAGS = (CONSTANTS => \@_Constants, ALL => \@EXPORT_OK); 42 43use base qw(Exporter); 44use Sun::Solaris::Exacct::Catalog qw(:CONSTANTS); 45 46# 47# Class methods 48# 49 50# 51# Dump an exacct object to the specified filehandle, or STDOUT by default. 52# 53sub dump 54{ 55 # Fettle parameters. 56 my ($class, $obj, $fh, $indent) = @_; 57 $fh ||= \*STDOUT; 58 $indent ||= 0; 59 my $istr = ' ' x $indent; 60 61 # Check for undef values. 62 if (! defined($obj)) { 63 print $fh ($istr, "UNDEFINED_VALUE\n"); 64 return; 65 } 66 67 # Deal with items. 68 my @cat = $obj->catalog()->value(); 69 if ($obj->type() == &EO_ITEM) { 70 printf $fh ("%sITEM\n%s Catalog = %s|%s|%s\n", 71 $istr, $istr, @cat); 72 $indent++; 73 my $val = $obj->value(); 74 75 # Recursively dump nested objects. 76 if (ref($val)) { 77 $class->dump($val, $fh, $indent); 78 79 # Just print out items. 80 } else { 81 $val = unpack('H*', $val) if ($cat[0] == &EXT_RAW); 82 printf $fh ("%s Value = %s\n", $istr, $val); 83 } 84 85 # Deal with groups. 86 } else { 87 printf $fh ("%sGROUP\n%s Catalog = %s|%s|%s\n", 88 $istr, $istr, @cat); 89 $indent++; 90 foreach my $val ($obj->value()) { 91 $class->dump($val, $fh, $indent); 92 } 93 printf $fh ("%sENDGROUP\n", $istr); 94 } 95} 96 97# 98# Item subclass - establish inheritance. 99# 100package Sun::Solaris::Exacct::Object::Item; 101use base qw(Sun::Solaris::Exacct::Object); 102 103# 104# Group subclass - establish inheritance. 105# 106package Sun::Solaris::Exacct::Object::Group; 107use base qw(Sun::Solaris::Exacct::Object); 108 109# 110# Tied array used for holding a group's items. 111# 112package Sun::Solaris::Exacct::Object::_Array; 113use Carp; 114 115# 116# Check the passed list of arguments are derived from ::Object 117# 118sub check_args 119{ 120 my @duff; 121 foreach my $i (@_) { 122 push(@duff, $i) 123 if (! UNIVERSAL::isa($i, 'Sun::Solaris::Exacct::Object')); 124 } 125 if (@duff) { 126 local $Carp::CarpLevel = 2; 127 croak('"', join('", "', @duff), @duff == 1 ? '" is' : '" are', 128 ' not of type Sun::Solaris::Exacct::Object'); 129 } 130} 131 132# 133# Tied hash access methods 134# 135sub TIEARRAY 136{ 137 return(bless([], $_[0])); 138} 139 140sub FETCHSIZE 141{ 142 return(scalar(@{$_[0]})); 143} 144 145sub STORESIZE 146{ 147 $#{$_[0]} = $_[1] - 1; 148} 149 150sub STORE 151{ 152 check_args($_[2]); 153 return($_[0]->[$_[1]] = copy_xs_ea_objects($_[2])); 154} 155 156sub FETCH 157{ 158 return($_[0]->[$_[1]]); 159} 160 161sub CLEAR 162{ 163 @{$_[0]} = (); 164} 165 166sub POP 167{ 168 return(pop(@{$_[0]})); 169} 170 171sub PUSH 172{ 173 my $a = shift(@_); 174 check_args(@_); 175 push(@$a, copy_xs_ea_objects(@_)); 176} 177 178sub SHIFT 179{ 180 return(shift(@{$_[0]})); 181} 182 183sub UNSHIFT 184{ 185 my $a = shift(@_); 186 check_args($_[2]); 187 return(unshift(@$a, copy_xs_ea_objects(@_))); 188} 189 190sub EXISTS 191{ 192 return(exists($_[0]->[$_[1]])); 193} 194 195sub DELETE 196{ 197 return(delete($_[0]->[$_[1]])); 198} 199 200sub EXTEND 201{ 202} 203 204sub SPLICE 205{ 206 my $a = shift(@_); 207 my $sz = scalar(@$a); 208 my $off = @_ ? shift(@_) : 0; 209 $off += $sz if $off < 0; 210 my $len = @_ ? shift : $sz - $off; 211 check_args(@_); 212 return(splice(@$a, $off, $len, copy_xs_ea_objects(@_))); 213} 214 2151; 216