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 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