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