Catalog.pm revision 12388:1bc8d55b0dfd 
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
9require 5.8.4;
10use strict;
11use warnings;
12
13package Sun::Solaris::Exacct::Catalog;
14
15our $VERSION = '1.3';
16use Carp;
17use XSLoader;
18XSLoader::load(__PACKAGE__, $VERSION);
19
20# %_Constants and @_Constants are set up by the XSUB bootstrap() function.
21our (@EXPORT_OK, %EXPORT_TAGS, @_Constants, %_Constants);
22@EXPORT_OK = @_Constants;
23%EXPORT_TAGS = (CONSTANTS => \@_Constants, ALL => \@EXPORT_OK);
24
25use 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#
52sub 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#
107sub 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#
159sub 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#
196sub 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#
210sub 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#
224sub 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#
242sub 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#
261sub 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#
280sub 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#
304sub 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#
345sub DESTROY
346{
347}
348
3491;
350