3900 illumos will not build against gcc compiled perl

          --- old/usr/src/cmd/perl/contrib/Sun/Solaris/Exacct/Object/Object.pm
          +++ new/usr/src/cmd/perl/contrib/Sun/Solaris/Exacct/Object/Object.pm
   1    1  #
   2    2  # Copyright (c) 2002, 2008, Oracle and/or its affiliates. All rights reserved.
   3    3  #
   4    4  
   5    5  #
   6    6  # Object.pm contains perl code for exacct object manipulation.
   7    7  #
   8    8  
   9      -require 5.8.4;
        9 +require 5.0010;
  10   10  use strict;
  11   11  use warnings;
  12   12  
  13   13  package Sun::Solaris::Exacct::Object;
  14   14  
  15   15  our $VERSION = '1.3';
  16   16  use XSLoader;
  17   17  XSLoader::load(__PACKAGE__, $VERSION);
  18   18  
  19   19  our (@EXPORT_OK, %EXPORT_TAGS, @_Constants);

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

XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX