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