1 /*
2 * Copyright (c) 2002, Oracle and/or its affiliates. All rights reserved.
3 */
4
5 /*
6 * Catalog.xs contains XS code for exacct catalog tag manipulation. This
7 * consists of code to create the @_Constants array and %_Constants hash used
8 * for defining constants on the fly via AUTOLOAD, and utility functions for
9 * creaing double-typed SVs.
10 */
11
12 #include "../exacct_common.xh"
13
14 /* Pull in the file generated by extract_defines. */
15 #include "CatalogDefs.xi"
16
17 /*
18 * This function populates the %_Constants hash and @_Constants array based on
19 * the values extracted from the exacct header files by the extract_defines
20 * script and written to the .xi file which is included above. It also creates
21 * a const sub for each constant that returns the associcated value. It should
22 * be called from the BOOT section of this module. The structure of the
23 * %_Constants hash is given below - this is used to map between the symbolic
24 * and numeric values of the various EX[CTD] constants. The register() method
25 * extends the %_Constants hash with values for the foreign catalog, so that it
26 * can be handled in exactly the same way as the built-in catalog.
27 *
28 * $Constants{catlg}{name}{EXC_DEFAULT} => 0
29 * ...
30 * {value}{0} => 'EXC_DEFAULT'
31 * ...
32 * *A*
33 * {id}{name}{EXD}{name}{EXD_CREATOR} => 3
34 * ...
35 * {value}{3} => 'EXD_CREATOR'
36 * ...
37 * {value}{0} => *A*
38 * ...
39 * {other}{name}{EXC_CATALOG_MASK} => 251658240
40 * ...
41 * {value}{251658240} => 'EXC_CATALOG_MASK'
42 * ...
43 * {type}{name}{EXT_DOUBLE} => 1342177280
44 * ...
45 * {value}{1342177280} => 'EXT_DOUBLE'
46 * ...
47 */
48 #define CONST_NAME "::Catalog::_Constants"
49 static void
define_catalog_constants()50 define_catalog_constants()
51 {
52 HV *const_hash, *hv1, *hv2, *hv3;
53 AV *const_ary;
54 HV *type_by_name, *type_by_value;
55 HV *catlg_by_name, *catlg_by_value;
56 HV *id_by_name, *id_by_value;
57 HV *other_by_name, *other_by_value;
58 constval_t *cvp;
59
60 /* Create the two new perl variables. */
61 const_hash = perl_get_hv(PKGBASE CONST_NAME, TRUE);
62 const_ary = perl_get_av(PKGBASE CONST_NAME, TRUE);
63
64 /* Create the 'type' subhash. */
65 type_by_name = newHV();
66 type_by_value = newHV();
67 hv1 = newHV();
68 hv_store(const_hash, "type", 4, newRV_noinc((SV*)hv1), 0);
69 hv_store(hv1, "name", 4, newRV_noinc((SV*)type_by_name), 0);
70 hv_store(hv1, "value", 5, newRV_noinc((SV*)type_by_value), 0);
71
72 /* Create the 'catlg' subhash. */
73 catlg_by_name = newHV();
74 catlg_by_value = newHV();
75 hv1 = newHV();
76 hv_store(const_hash, "catlg", 5, newRV_noinc((SV*)hv1), 0);
77 hv_store(hv1, "name", 4, newRV_noinc((SV*)catlg_by_name), 0);
78 hv_store(hv1, "value", 5, newRV_noinc((SV*)catlg_by_value), 0);
79
80 /*
81 * The 'id' subhash has an extra level of name/value subhashes,
82 * where the upper level is indexed by the catalog prefix (EXD for
83 * the default catalog). The lower two levels are actually the same
84 * hashes referenced by two parents, and hold the catalog id numeric
85 * values and corresponding string values.
86 */
87 id_by_name = newHV();
88 id_by_value = newHV();
89 hv1 = newHV();
90 hv_store(const_hash, "id", 2, newRV_noinc((SV*)hv1), 0);
91 hv2 = newHV();
92 hv_store(hv1, "name", 4, newRV_noinc((SV*)hv2), 0);
93 hv3 = newHV();
94 hv_store(hv2, "EXD", 3, newRV_noinc((SV*)hv3), 0);
95 hv_store(hv3, "name", 4, newRV_noinc((SV*)id_by_name), 0);
96 hv_store(hv3, "value", 5, newRV_noinc((SV*)id_by_value), 0);
97 IdValueHash = newHV();
98 hv_store(hv1, "value", 5, newRV_noinc((SV*)IdValueHash), 0);
99 hv_store_ent(IdValueHash, newSVuv(EXC_DEFAULT), newRV_inc((SV*)hv3), 0);
100
101 /* Create the 'other' subhash, for non-catalog #defines. */
102 other_by_name = newHV();
103 other_by_value = newHV();
104 hv1 = newHV();
105 hv_store(const_hash, "other", 5, newRV_noinc((SV*)hv1), 0);
106 hv_store(hv1, "name", 4, newRV_noinc((SV*)other_by_name), 0);
107 hv_store(hv1, "value", 5, newRV_noinc((SV*)other_by_value), 0);
108
109 /*
110 * Populate %_Constants and %_Constants from the contents of the
111 * generated constants array.
112 */
113 for (cvp = constants; cvp->name != NULL; cvp++) {
114 HV *name_hv, *value_hv;
115 SV *name, *value;
116
117 /* Create the name/value SVs, save the name in @_Constants. */
118 name = newSVpvn((char *)cvp->name, cvp->len);
119 value = newSVuv(cvp->value);
120 av_push(const_ary, SvREFCNT_inc(name));
121
122 /*
123 * Decide which hash the name/value belong in,
124 * based on consttype .
125 */
126 switch (cvp->consttype) {
127 case type:
128 name_hv = type_by_name;
129 value_hv = type_by_value;
130 break;
131 case catlg:
132 name_hv = catlg_by_name;
133 /* Special case for duplicated-value EXC_NONE tag. */
134 if (cvp->value == EXC_NONE &&
135 strcmp(cvp->name, "EXC_NONE") == 0) {
136 value_hv = NULL;
137 } else {
138 value_hv = catlg_by_value;
139 }
140 break;
141 case id:
142 name_hv = id_by_name;
143 value_hv = id_by_value;
144 break;
145 case other:
146 name_hv = other_by_name;
147 value_hv = other_by_value;
148 break;
149 }
150
151 /* Store in the appropriate name & value hashes. */
152 if (name_hv) {
153 hv_store_ent(name_hv, name, value, 0);
154 }
155 if (value_hv) {
156 hv_store_ent(value_hv, value, name, 0);
157 }
158
159 /* Free the name and/or value if they weren't used. */
160 if (! name_hv) {
161 SvREFCNT_dec(value);
162 }
163 if (! value_hv) {
164 SvREFCNT_dec(name);
165 }
166 }
167 }
168 #undef CONST_NAME
169
170 /*
171 * The XS code exported to perl is below here. Note that the XS preprocessor
172 * has its own commenting syntax, so all comments from this point on are in
173 * that form.
174 *
175 * All the following are private functions.
176 */
177
178 MODULE = Sun::Solaris::Exacct::Catalog PACKAGE = Sun::Solaris::Exacct::Catalog
179 PROTOTYPES: ENABLE
180
181 #
182 # Define the stash pointers if required and create and populate @_Constants.
183 #
184 BOOT:
185 init_stashes();
186 define_catalog_constants();
187
188 #
189 # Create and return a double-typed SV.
190 #
191 SV*
192 _double_type(i, c)
193 unsigned int i;
194 char *c;
195 CODE:
196 RETVAL = newSVuv(i);
197 sv_setpv(RETVAL, c);
198 SvIOK_on(RETVAL);
199 OUTPUT:
200 RETVAL
201
202 #
203 # Return true if the SV contains an IV.
204 #
205 int
206 _is_iv(sv)
207 SV *sv;
208 CODE:
209 RETVAL = SvIOK(sv);
210 OUTPUT:
211 RETVAL
212
213 #
214 # Return true if the SV contains a PV.
215 #
216 int
217 _is_pv(sv)
218 SV *sv;
219 CODE:
220 RETVAL = SvPOK(sv);
221 OUTPUT:
222 RETVAL
223
224 #
225 # Return a blessed reference to a readonly copy of the passed IV
226 #
227 SV*
228 _new_catalog(sv)
229 SV *sv;
230 CODE:
231 RETVAL = new_catalog(SvUV(sv));
232 OUTPUT:
233 RETVAL
234
235 #
236 # Return the integer catalog value from the passed object or SV.
237 #
238 int
239 _catalog_value(sv)
240 SV *sv;
241 CODE:
242 RETVAL = catalog_value(sv);
243 OUTPUT:
244 RETVAL
245