usr/src/cmd/perl/contrib/Sun/Solaris/Exacct/Object/Object.pm

   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
   9 require 5.8.4;
  10 use strict;
  11 use warnings;
  12
  13 package Sun::Solaris::Exacct::Object;
  14
  15 our $VERSION = '1.3';
  16 use XSLoader;
  17 XSLoader::load(__PACKAGE__, $VERSION);
  18
  19 our (@EXPORT_OK, %EXPORT_TAGS, @_Constants);
  20 @EXPORT_OK = @_Constants;
  21 %EXPORT_TAGS = (CONSTANTS => \@_Constants, ALL => \@EXPORT_OK);
  22
  23 use base qw(Exporter);
  24 use 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 #
  33 sub 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 #
  80 package Sun::Solaris::Exacct::Object::Item;
  81 use base qw(Sun::Solaris::Exacct::Object);
  82
  83 #
  84 # Group subclass - establish inheritance.
  85 #
  86 package Sun::Solaris::Exacct::Object::Group;
  87 use base qw(Sun::Solaris::Exacct::Object);
  88
  89 #
  90 # Tied array used for holding a group's items.
  91 #
  92 package Sun::Solaris::Exacct::Object::_Array;
  93 use Carp;
  94
  95 #
  96 # Check the passed list of arguments are derived from ::Object
  97 #
  98 sub 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 #
 115 sub TIEARRAY
 116 {
 117         return(bless([], $_[0]));
 118 }
 119
 120 sub FETCHSIZE
 121 {
 122         return(scalar(@{$_[0]}));
 123 }
 124
 125 sub STORESIZE
 126 {
 127         $#{$_[0]} = $_[1] - 1;
 128 }
 129
 130 sub STORE
 131 {
 132         check_args($_[2]);
 133         return($_[0]->[$_[1]] = copy_xs_ea_objects($_[2]));
 134 }
 135
 136 sub FETCH
 137 {
 138         return($_[0]->[$_[1]]);
 139 }
 140
 141 sub CLEAR
 142 {
 143         @{$_[0]} = ();
 144 }
 145
 146 sub POP
 147 {
 148         return(pop(@{$_[0]}));
 149 }
 150
 151 sub PUSH
 152 {
 153         my $a = shift(@_);
 154         check_args(@_);
 155         push(@$a, copy_xs_ea_objects(@_));
 156 }
 157
 158 sub SHIFT
 159 {
 160         return(shift(@{$_[0]}));
 161 }
 162
 163 sub UNSHIFT
 164 {
 165         my $a = shift(@_);
 166         check_args($_[2]);
 167         return(unshift(@$a, copy_xs_ea_objects(@_)));
 168 }
 169
 170 sub EXISTS
 171 {
 172         return(exists($_[0]->[$_[1]]));
 173 }
 174
 175 sub DELETE
 176 {
 177         return(delete($_[0]->[$_[1]]));
 178 }
 179
 180 sub EXTEND
 181 {
 182 }
 183
 184 sub 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
 195 1;