1N/A#
1N/A# Copyright (c) 2002, 2008, Oracle and/or its affiliates. All rights reserved.
1N/A#
1N/A
1N/A#
1N/A# Object.pm contains perl code for exacct object manipulation.
1N/A#
1N/A
1N/Arequire 5.8.4;
1N/Ause strict;
1N/Ause warnings;
1N/A
1N/Apackage Sun::Solaris::Exacct::Object;
1N/A
1N/Aour $VERSION = '1.3';
1N/Ause XSLoader;
1N/AXSLoader::load(__PACKAGE__, $VERSION);
1N/A
1N/Aour (@EXPORT_OK, %EXPORT_TAGS, @_Constants);
1N/A@EXPORT_OK = @_Constants;
1N/A%EXPORT_TAGS = (CONSTANTS => \@_Constants, ALL => \@EXPORT_OK);
1N/A
1N/Ause base qw(Exporter);
1N/Ause Sun::Solaris::Exacct::Catalog qw(:CONSTANTS);
1N/A
1N/A#
1N/A# Class methods
1N/A#
1N/A
1N/A#
1N/A# Dump an exacct object to the specified filehandle, or STDOUT by default.
1N/A#
1N/Asub dump
1N/A{
1N/A # Fettle parameters.
1N/A my ($class, $obj, $fh, $indent) = @_;
1N/A $fh ||= \*STDOUT;
1N/A $indent ||= 0;
1N/A my $istr = ' ' x $indent;
1N/A
1N/A # Check for undef values.
1N/A if (! defined($obj)) {
1N/A print $fh ($istr, "UNDEFINED_VALUE\n");
1N/A return;
1N/A }
1N/A
1N/A # Deal with items.
1N/A my @cat = $obj->catalog()->value();
1N/A if ($obj->type() == &EO_ITEM) {
1N/A printf $fh ("%sITEM\n%s Catalog = %s|%s|%s\n",
1N/A $istr, $istr, @cat);
1N/A $indent++;
1N/A my $val = $obj->value();
1N/A
1N/A # Recursively dump nested objects.
1N/A if (ref($val)) {
1N/A $class->dump($val, $fh, $indent);
1N/A
1N/A # Just print out items.
1N/A } else {
1N/A $val = unpack('H*', $val) if ($cat[0] == &EXT_RAW);
1N/A printf $fh ("%s Value = %s\n", $istr, $val);
1N/A }
1N/A
1N/A # Deal with groups.
1N/A } else {
1N/A printf $fh ("%sGROUP\n%s Catalog = %s|%s|%s\n",
1N/A $istr, $istr, @cat);
1N/A $indent++;
1N/A foreach my $val ($obj->value()) {
1N/A $class->dump($val, $fh, $indent);
1N/A }
1N/A printf $fh ("%sENDGROUP\n", $istr);
1N/A }
1N/A}
1N/A
1N/A#
1N/A# Item subclass - establish inheritance.
1N/A#
1N/Apackage Sun::Solaris::Exacct::Object::Item;
1N/Ause base qw(Sun::Solaris::Exacct::Object);
1N/A
1N/A#
1N/A# Group subclass - establish inheritance.
1N/A#
1N/Apackage Sun::Solaris::Exacct::Object::Group;
1N/Ause base qw(Sun::Solaris::Exacct::Object);
1N/A
1N/A#
1N/A# Tied array used for holding a group's items.
1N/A#
1N/Apackage Sun::Solaris::Exacct::Object::_Array;
1N/Ause Carp;
1N/A
1N/A#
1N/A# Check the passed list of arguments are derived from ::Object
1N/A#
1N/Asub check_args
1N/A{
1N/A my @duff;
1N/A foreach my $i (@_) {
1N/A push(@duff, $i)
1N/A if (! UNIVERSAL::isa($i, 'Sun::Solaris::Exacct::Object'));
1N/A }
1N/A if (@duff) {
1N/A local $Carp::CarpLevel = 2;
1N/A croak('"', join('", "', @duff), @duff == 1 ? '" is' : '" are',
1N/A ' not of type Sun::Solaris::Exacct::Object');
1N/A }
1N/A}
1N/A
1N/A#
1N/A# Tied hash access methods
1N/A#
1N/Asub TIEARRAY
1N/A{
1N/A return(bless([], $_[0]));
1N/A}
1N/A
1N/Asub FETCHSIZE
1N/A{
1N/A return(scalar(@{$_[0]}));
1N/A}
1N/A
1N/Asub STORESIZE
1N/A{
1N/A $#{$_[0]} = $_[1] - 1;
1N/A}
1N/A
1N/Asub STORE
1N/A{
1N/A check_args($_[2]);
1N/A return($_[0]->[$_[1]] = copy_xs_ea_objects($_[2]));
1N/A}
1N/A
1N/Asub FETCH
1N/A{
1N/A return($_[0]->[$_[1]]);
1N/A}
1N/A
1N/Asub CLEAR
1N/A{
1N/A @{$_[0]} = ();
1N/A}
1N/A
1N/Asub POP
1N/A{
1N/A return(pop(@{$_[0]}));
1N/A}
1N/A
1N/Asub PUSH
1N/A{
1N/A my $a = shift(@_);
1N/A check_args(@_);
1N/A push(@$a, copy_xs_ea_objects(@_));
1N/A}
1N/A
1N/Asub SHIFT
1N/A{
1N/A return(shift(@{$_[0]}));
1N/A}
1N/A
1N/Asub UNSHIFT
1N/A{
1N/A my $a = shift(@_);
1N/A check_args($_[2]);
1N/A return(unshift(@$a, copy_xs_ea_objects(@_)));
1N/A}
1N/A
1N/Asub EXISTS
1N/A{
1N/A return(exists($_[0]->[$_[1]]));
1N/A}
1N/A
1N/Asub DELETE
1N/A{
1N/A return(delete($_[0]->[$_[1]]));
1N/A}
1N/A
1N/Asub EXTEND
1N/A{
1N/A}
1N/A
1N/Asub SPLICE
1N/A{
1N/A my $a = shift(@_);
1N/A my $sz = scalar(@$a);
1N/A my $off = @_ ? shift(@_) : 0;
1N/A $off += $sz if $off < 0;
1N/A my $len = @_ ? shift : $sz - $off;
1N/A check_args(@_);
1N/A return(splice(@$a, $off, $len, copy_xs_ea_objects(@_)));
1N/A}
1N/A
1N/A1;