1 #
   2 # Copyright (c) 2002, 2008 Oracle and/or its affiliates. All rights reserved.
   3 #
   4 
   5 #
   6 # Catalog.pm contains perl code for exacct catalog tag manipulation.
   7 # 
   8 
   9 require 5.8.4;
  10 use strict;
  11 use warnings;
  12 
  13 package Sun::Solaris::Exacct::Catalog;
  14 
  15 our $VERSION = '1.3';
  16 use Carp;
  17 use XSLoader;
  18 XSLoader::load(__PACKAGE__, $VERSION);
  19 
  20 # %_Constants and @_Constants are set up by the XSUB bootstrap() function.
  21 our (@EXPORT_OK, %EXPORT_TAGS, @_Constants, %_Constants);
  22 @EXPORT_OK = @_Constants;
  23 %EXPORT_TAGS = (CONSTANTS => \@_Constants, ALL => \@EXPORT_OK);
  24 
  25 use base qw(Exporter);
  26 
  27 #
  28 # Class interface.
  29 #
  30 
  31 #
  32 # Register a foreign catalog.  Arguments are as follows:
  33 #    <catalog prefix>     Used to uniquely identify the catalog being defined.
  34 #                       Must be composed only of uppercase characters.
  35 #    <catalog id> Numeric identifier for the catalog.
  36 #                       Must be between 1 and 15.
  37 #    <export flag>        If true, the constants defined by the register sub will
  38 #                       be exported into the caller's namespace.
  39 #    <id list>            List of (name, value) pairs.  These are prefixed with
  40 #                       "<catalog_prefix>_" and are used for defining constants
  41 #                       that can be used as catalog id field values.
  42 # An example:
  43 #    Sun::Solaris::Exacct::Catalog->register("FROB", 0x01, 1,
  44 #        FLUB => 0x00000001, WURB => 0x00000010)
  45 # results in the definition of the following constants:
  46 #    EXC_FROB   0x01 << 24
  47 #    FROB_FLUB  0x00000001
  48 #    FROB_WURB  0x00000010
  49 #
  50 # Returns 'undef' on success, otherwise an error message.
  51 #
  52 sub register
  53 {
  54         my ($class, $cat_pfx, $cat_id, $export, %idlist) = @_;
  55 
  56         # Sanity checks.
  57         my $cat = 'EXC_'. $cat_pfx;
  58         return ("Invalid catalog prefix \"$cat_pfx\"")
  59             if ($cat_pfx !~ /^[A-Z][A-Z0-9]*$/ || $cat_pfx =~ /^EX[TCD]$/);
  60         return ("Duplicate catalog prefix")
  61             if (exists($_Constants{catlg}{name}{$cat}));
  62         my $id = $cat_id << 24;
  63         return ("Invalid catalog id \"$cat_id\"")
  64             if ($cat_id < 1 || $cat_id > 0xf);   # 4-bit field
  65         
  66         # Validate the (name, value) pairs.
  67         my %seen;
  68         while (my ($n, $v) = each(%idlist)) {
  69                 return ("Invalid id name \"$n\"")
  70                     if ($n !~ /^[A-Z][A-Z0-9_]*[A-Z0-9]$/);
  71                 return ("Invalid id value \"$v\"")
  72                     if ($v < 0 || $v > 0xffffff);   # 24-bit field
  73                 return ("Redefinition of id value \"$v\"")
  74                     if ($seen{$v}++);
  75         }
  76         undef(%seen);
  77 
  78         # Initialise new lookup data members
  79         $_Constants{catlg}{name}{$cat} = $id;
  80         $_Constants{catlg}{value}{$id} = $cat;
  81         my $id_by_name = $_Constants{id}{name}{$cat_pfx}{name}  = {};
  82         my $id_by_val  = $_Constants{id}{name}{$cat_pfx}{value} = {};
  83         $_Constants{id}{value}{$id} = $_Constants{id}{name}{$cat_pfx};
  84 
  85         # Put the passed (name, value) pairs into the appropriate hashes.
  86         my @export_ok = ($cat);
  87         while (my ($n, $v) = each(%idlist)) {
  88                 my $pn = "${cat_pfx}_${n}";
  89                 $id_by_name->{$pn} = $v;
  90                 $id_by_val->{$v}  = $pn;
  91                 push(@export_ok, $pn);
  92         }
  93 
  94         # Export the new symbols into the caller's namespace if required.
  95         if ($export) {
  96                 our (%EXPORT, @EXPORT_OK);
  97                 @EXPORT{@export_ok} = (1) x @export_ok;
  98                 push(@EXPORT_OK, @export_ok);
  99                 __PACKAGE__->export_to_level(1, undef, @export_ok);
 100         }
 101 }
 102 
 103 #
 104 # Create a new Catalog object.  Arguments are either an integer, an existing
 105 # Catalog object or a (type, catalog, id) triplet.
 106 #
 107 sub new
 108 {
 109         my ($class, @vals) = @_;
 110         my $value;
 111 
 112         # A single value must be a full catalog tag 
 113         if (@vals == 1) {
 114                 $value = _catalog_value($vals[0]);
 115 
 116         # A list of 3 values is (type, catalog, id)
 117         } elsif (@vals == 3) {
 118                 my ($t, $c, $d) = @vals;
 119                 my ($which);
 120 
 121                 $which = _is_iv($t) ? 'value' : 'name';
 122                 croak("Invalid data type \"$t\"")
 123                     if (! exists($_Constants{type}{$which}{$t}));
 124                 $t = $_Constants{type}{name}{$t} if ($which eq 'name');
 125 
 126                 $which = _is_iv($c) ? 'value' : 'name';
 127                 croak("Invalid catalog \"$c\"")
 128                     if (! exists($_Constants{catlg}{$which}{$c}));
 129                 $c = $_Constants{catlg}{name}{$c} if ($which eq 'name');
 130 
 131                 $which = _is_iv($d) ? 'value' : 'name';
 132                 croak("Invalid data id \"$d\"")
 133                     if (! exists($_Constants{id}{value}{$c}{$which}{$d}));
 134                 $d = $_Constants{id}{value}{$c}{name}{$d} if ($which eq 'name');
 135 
 136                 $value = $t | $c | $d;
 137 
 138         # Only 1 or 3 arguments are valid
 139         } else {
 140                 croak("Invalid number of arguments");
 141         }
 142 
 143         # Create a readonly catalog object.
 144         return (_new_catalog($value));
 145 }
 146 
 147 #
 148 # Object interface.
 149 #
 150 
 151 #
 152 # Get the value of a Catalog object.  In a scalar context it returns the 32-bit
 153 # integer representing the tag.  In a list context it returns a
 154 # (type, catalog, id) triplet.  Each of these is a dual-typed SV that in a
 155 # string context returns a representation of the appropriate constant, e.g.
 156 # 'EXD_HOSTNAME', and in a numeric context returns the integer value of the
 157 # associated constant.
 158 #
 159 sub value
 160 {
 161         my ($self) = @_;
 162 
 163         # In an array context return the split out catalog components
 164         if (wantarray()) {
 165                 my $t = $$self & &EXT_TYPE_MASK;
 166                 $t = _double_type($t, exists($_Constants{type}{value}{$t})
 167                     ? $_Constants{type}{value}{$t}
 168                     : 'UNKNOWN_TYPE');
 169 
 170                 my $c = $$self & &EXC_CATALOG_MASK;
 171                 $c = _double_type($c,
 172                     exists($_Constants{catlg}{value}{$c})
 173                     ? $_Constants{catlg}{value}{$c}
 174                     : 'UNKNOWN_CATALOG');
 175 
 176                 my $d = $$self & &EXD_DATA_MASK;
 177                 $d = _double_type($d,
 178                     exists($_Constants{id}{value}{int($c)}{value}{$d})
 179                     ? $_Constants{id}{value}{int($c)}{value}{$d}
 180                     : 'UNKNOWN_ID');
 181 
 182                 return($t, $c, $d);
 183 
 184         # In a scalar context return the whole thing
 185         } else {
 186                 return($$self);
 187         }
 188 }
 189 
 190 #
 191 # Fetch the type field of the Catalog object.  The return value is a dual-typed
 192 # SV that in a string context returns a representation of the appropriate
 193 # constant, e.g. 'EXT_STRING', and in a numeric context returns the integer
 194 # value of the associated constant.
 195 #
 196 sub type
 197 {
 198         my ($self) = @_;
 199 
 200         # Extract the type field and look up the string representation.
 201         my $t = $$self & &EXT_TYPE_MASK;
 202         $t = _double_type($t, exists($_Constants{type}{value}{$t})
 203             ? $_Constants{type}{value}{$t} : 'UNKNOWN_TYPE');
 204         return ($t);
 205 }
 206 
 207 #
 208 # Fetch the catalog field of the Catalog object.  (see type()).
 209 #
 210 sub catalog
 211 {
 212         my ($self, $val) = @_;
 213 
 214         # Extract the catalog field and look up the string representation.
 215         my $c = $$self & &EXC_CATALOG_MASK;
 216         $c = _double_type($c, exists($_Constants{catlg}{value}{$c})
 217             ? $_Constants{catlg}{value}{$c} : 'UNKNOWN_CATALOG');
 218         return ($c);
 219 }
 220 
 221 #
 222 # Fetch the id field of the Catalog object.  (see type()).
 223 #
 224 sub id
 225 {
 226         my ($self, $val) = @_;
 227 
 228         #
 229         # Extract the catalog and id field and look up the
 230         # string representation of the id field.
 231         #
 232         my $c = $$self & &EXC_CATALOG_MASK;
 233         my $d = $$self & &EXD_DATA_MASK;
 234         $d = _double_type($d, exists($_Constants{id}{value}{$c}{value}{$d})
 235             ? $_Constants{id}{value}{$c}{value}{$d} : 'UNKNOWN_ID');
 236         return ($d);
 237 }
 238 
 239 #
 240 # Return a string representation of the type field.
 241 #
 242 sub type_str
 243 {
 244         my ($self) = @_;
 245 
 246         # Lookup the type and fabricate a string from it.
 247         my $t = $$self & &EXT_TYPE_MASK;
 248         if (exists($_Constants{type}{value}{$t})) {
 249                 $t = $_Constants{type}{value}{$t};
 250                 $t =~ s/^EXT_//;
 251                 $t =~ s/_/ /g;
 252                 return(lc($t));
 253         } else {
 254                 return('UNKNOWN TYPE');
 255         }
 256 }
 257 
 258 #
 259 # Return a string representation of the catalog field.
 260 #
 261 sub catalog_str
 262 {
 263         my ($self) = @_;
 264 
 265         # Lookup the catalog and fabricate a string from it.
 266         my $c = $$self & &EXC_CATALOG_MASK;
 267         if (exists($_Constants{catlg}{value}{$c})) {
 268                 $c = $_Constants{catlg}{value}{$c};
 269                 $c =~ s/^EXC_//;
 270                 $c =~ s/_/ /g;
 271                 return(lc($c));
 272         } else {
 273                 return('UNKNOWN CATALOG');
 274         }
 275 }
 276 
 277 #
 278 # Return a string representation of the id field.
 279 #
 280 sub id_str
 281 {
 282         my ($self) = @_;
 283 
 284         # Lookup the id and fabricate a string from it.
 285         my $c = $$self & &EXC_CATALOG_MASK;
 286         my $d = $$self & &EXD_DATA_MASK;
 287         if (exists($_Constants{id}{value}{$c}) &&
 288             exists($_Constants{id}{value}{$c}{value}{$d})) {
 289                 $d = $_Constants{id}{value}{$c}{value}{$d};
 290                 $d =~ s/^[A-Z]+_//;
 291                 $d =~ s/_/ /g;
 292                 return(lc($d));
 293         } else {
 294                 return('UNKNOWN ID');
 295         }
 296 }
 297 
 298 #
 299 # AUTOLOAD for constant definitions.  Values are looked up in the %_Constants
 300 # hash, and then used to create an anonymous sub that will return the correct
 301 # value.  This is then placed into the appropriate symbol table so that future
 302 # calls will bypass the AUTOLOAD and call the sub directly.
 303 #
 304 sub AUTOLOAD
 305 {
 306         # Extract the name of the constant we are looking for, and its prefix.
 307         our $AUTOLOAD;
 308         my $const = $AUTOLOAD;
 309         $const =~ s/.*:://;
 310         my ($prefix) = $const =~ /^([^_]+)/;
 311 
 312         # Try to find the appropriate prefix hash.
 313         my $href;
 314         if ($prefix eq 'EXT') {
 315                 $href = $_Constants{type}{name};
 316         } elsif ($prefix eq 'EXC') {
 317                 $href = $_Constants{catlg}{name};
 318         } elsif (exists($_Constants{id}{name}{$prefix})) {
 319                 $href = $_Constants{id}{name}{$prefix}{name};
 320         }
 321 
 322         # Look first in the prefix hash, otherwise try the 'other' hash.
 323         my $val = undef;
 324         if (exists($href->{$const})) {
 325                 $val = $href->{$const};
 326         } elsif (exists($_Constants{other}{name}{$const})) {
 327                 $val = $_Constants{other}{name}{$const};
 328         }
 329 
 330         #
 331         # Generate the const sub,  place in the appropriate glob
 332         # and finally goto it to return the value.
 333         #
 334         croak("Undefined constant \"$const\"") if (! defined($val));
 335         my $sub = sub { return $val; };
 336         no strict qw(refs);
 337         *{$AUTOLOAD} = $sub;
 338         goto &$sub;
 339 }
 340 
 341 #
 342 # To quieten AUTOLOAD - if this isn't defined AUTLOAD will be called
 343 # unnecessarily during object destruction.
 344 #
 345 sub DESTROY
 346 {
 347 }
 348 
 349 1;