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;