1# 2# Copyright (c) 2002, 2008, Oracle and/or its affiliates. All rights reserved. 3# 4 5# 6# Object.pm contains perl code for exacct object manipulation. 7# 8 9require 5.8.4; 10use strict; 11use warnings; 12 13package Sun::Solaris::Exacct::Object; 14 15our $VERSION = '1.3'; 16use XSLoader; 17XSLoader::load(__PACKAGE__, $VERSION); 18 19our (@EXPORT_OK, %EXPORT_TAGS, @_Constants); 20@EXPORT_OK = @_Constants; 21%EXPORT_TAGS = (CONSTANTS => \@_Constants, ALL => \@EXPORT_OK); 22 23use base qw(Exporter); 24use Sun::Solaris::Exacct::Catalog qw(:CONSTANTS); 25 26# 27# Class methods 28# 29 30# 31# Dump an exacct object to the specified filehandle, or STDOUT by default. 32# 33sub dump 34{ 35 # Fettle parameters. 36 my ($class, $obj, $fh, $indent) = @_; 37 $fh ||= \*STDOUT; 38 $indent ||= 0; 39 my $istr = ' ' x $indent; 40 41 # Check for undef values. 42 if (! defined($obj)) { 43 print $fh ($istr, "UNDEFINED_VALUE\n"); 44 return; 45 } 46 47 # Deal with items. 48 my @cat = $obj->catalog()->value(); 49 if ($obj->type() == &EO_ITEM) { 50 printf $fh ("%sITEM\n%s Catalog = %s|%s|%s\n", 51 $istr, $istr, @cat); 52 $indent++; 53 my $val = $obj->value(); 54 55 # Recursively dump nested objects. 56 if (ref($val)) { 57 $class->dump($val, $fh, $indent); 58 59 # Just print out items. 60 } else { 61 $val = unpack('H*', $val) if ($cat[0] == &EXT_RAW); 62 printf $fh ("%s Value = %s\n", $istr, $val); 63 } 64 65 # Deal with groups. 66 } else { 67 printf $fh ("%sGROUP\n%s Catalog = %s|%s|%s\n", 68 $istr, $istr, @cat); 69 $indent++; 70 foreach my $val ($obj->value()) { 71 $class->dump($val, $fh, $indent); 72 } 73 printf $fh ("%sENDGROUP\n", $istr); 74 } 75} 76 77# 78# Item subclass - establish inheritance. 79# 80package Sun::Solaris::Exacct::Object::Item; 81use base qw(Sun::Solaris::Exacct::Object); 82 83# 84# Group subclass - establish inheritance. 85# 86package Sun::Solaris::Exacct::Object::Group; 87use base qw(Sun::Solaris::Exacct::Object); 88 89# 90# Tied array used for holding a group's items. 91# 92package Sun::Solaris::Exacct::Object::_Array; 93use Carp; 94 95# 96# Check the passed list of arguments are derived from ::Object 97# 98sub check_args 99{ 100 my @duff; 101 foreach my $i (@_) { 102 push(@duff, $i) 103 if (! UNIVERSAL::isa($i, 'Sun::Solaris::Exacct::Object')); 104 } 105 if (@duff) { 106 local $Carp::CarpLevel = 2; 107 croak('"', join('", "', @duff), @duff == 1 ? '" is' : '" are', 108 ' not of type Sun::Solaris::Exacct::Object'); 109 } 110} 111 112# 113# Tied hash access methods 114# 115sub TIEARRAY 116{ 117 return(bless([], $_[0])); 118} 119 120sub FETCHSIZE 121{ 122 return(scalar(@{$_[0]})); 123} 124 125sub STORESIZE 126{ 127 $#{$_[0]} = $_[1] - 1; 128} 129 130sub STORE 131{ 132 check_args($_[2]); 133 return($_[0]->[$_[1]] = copy_xs_ea_objects($_[2])); 134} 135 136sub FETCH 137{ 138 return($_[0]->[$_[1]]); 139} 140 141sub CLEAR 142{ 143 @{$_[0]} = (); 144} 145 146sub POP 147{ 148 return(pop(@{$_[0]})); 149} 150 151sub PUSH 152{ 153 my $a = shift(@_); 154 check_args(@_); 155 push(@$a, copy_xs_ea_objects(@_)); 156} 157 158sub SHIFT 159{ 160 return(shift(@{$_[0]})); 161} 162 163sub UNSHIFT 164{ 165 my $a = shift(@_); 166 check_args($_[2]); 167 return(unshift(@$a, copy_xs_ea_objects(@_))); 168} 169 170sub EXISTS 171{ 172 return(exists($_[0]->[$_[1]])); 173} 174 175sub DELETE 176{ 177 return(delete($_[0]->[$_[1]])); 178} 179 180sub EXTEND 181{ 182} 183 184sub SPLICE 185{ 186 my $a = shift(@_); 187 my $sz = scalar(@$a); 188 my $off = @_ ? shift(@_) : 0; 189 $off += $sz if $off < 0; 190 my $len = @_ ? shift : $sz - $off; 191 check_args(@_); 192 return(splice(@$a, $off, $len, copy_xs_ea_objects(@_))); 193} 194 1951; 196