| blob | 459138cd10920b48cd2ac22c204efa53c53a32d1 |
1 /*
2 * Copyright (c) 2002, Oracle and/or its affiliates. All rights reserved.
3 *
4 * Exacct.xs contains XS code for creating various exacct-related constants,
5 * and for providing wrappers around exacct error handling and
6 * accounting-related system calls. It also contains commonly-used utility
7 * code shared by its sub-modules.
8 */
10 #include <string.h>
11 #include "exacct_common.xh"
13 /*
14 * Pull in the file generated by extract_defines. This contains a table
15 * of numeric constants and their string equivalents which have been extracted
16 * from the various exacct header files by the extract_defines script.
17 */
18 #include "ExacctDefs.xi"
20 /*
21 * Object stash pointers - caching these speeds up the creation and
22 * typechecking of perl objects by removing the need to do a hash lookup.
23 * The peculiar variable names are so that typemaps can generate the correct
24 * package name using the typemap '$Package' variable as the root of the name.
25 */
26 HV *Sun_Solaris_Exacct_Catalog_stash;
27 HV *Sun_Solaris_Exacct_File_stash;
28 HV *Sun_Solaris_Exacct_Object_Item_stash;
29 HV *Sun_Solaris_Exacct_Object_Group_stash;
30 HV *Sun_Solaris_Exacct_Object__Array_stash;
32 /*
33 * Pointer to part of the hash tree built by define_catalog_constants in
34 * Catalog.xs. This is used by catalog_id_str() when mapping from a catalog
35 * to an id string.
36 */
37 HV *IdValueHash = NULL;
39 /*
40 * Last buffer size used for packing and unpacking exacct objects.
41 */
42 static int last_bufsz = 0;
44 /*
45 * Common utility code. This is placed here instead of in the sub-modules to
46 * reduce the number of cross-module linker dependencies that are required,
47 * although most of the code more properly belongs in the sub-modules.
48 */
50 /*
51 * This function populates the various stash pointers used by the ::Exacct
52 * module. It is called from each of the module BOOT sections to ensure the
53 * stash pointers are initialised on startup.
54 */
55 void
56 init_stashes(void)
57 {
58 if (Sun_Solaris_Exacct_Catalog_stash == NULL) {
59 Sun_Solaris_Exacct_Catalog_stash =
60 gv_stashpv(PKGBASE "::Catalog", TRUE);
61 Sun_Solaris_Exacct_File_stash =
62 gv_stashpv(PKGBASE "::File", TRUE);
63 Sun_Solaris_Exacct_Object_Item_stash =
64 gv_stashpv(PKGBASE "::Object::Item", TRUE);
65 Sun_Solaris_Exacct_Object_Group_stash =
66 gv_stashpv(PKGBASE "::Object::Group", TRUE);
67 Sun_Solaris_Exacct_Object__Array_stash =
68 gv_stashpv(PKGBASE "::Object::_Array", TRUE);
69 }
70 }
72 /*
73 * This function populates the @_Constants array in the specified package
74 * based on the values extracted from the exacct header files by the
75 * extract_defines script and written to the .xi file which is included above.
76 * It also creates a const sub for each constant that returns the associcated
77 * value. It should be called from the BOOT sections of modules that export
78 * constants.
79 */
80 #define CONST_NAME "::_Constants"
81 void
82 define_constants(const char *pkg, constval_t *cvp)
83 {
84 HV *stash;
85 char *name;
86 AV *constants;
88 /* Create the new perl @_Constants variable. */
89 stash = gv_stashpv(pkg, TRUE);
90 name = New(0, name, strlen(pkg) + sizeof (CONST_NAME), char);
91 PERL_ASSERT(name != NULL);
92 strcpy(name, pkg);
93 strcat(name, CONST_NAME);
94 constants = perl_get_av(name, TRUE);
95 Safefree(name);
97 /* Populate @_Constants from the contents of the generated array. */
98 for (; cvp->name != NULL; cvp++) {
99 newCONSTSUB(stash, (char *)cvp->name, newSVuv(cvp->value));
100 av_push(constants, newSVpvn((char *)cvp->name, cvp->len));
101 }
102 }
103 #undef CONST_NAME
105 /*
106 * Return a new Catalog object - only accepts an integer catalog value.
107 * Use this purely for speed when creating Catalog objects from other XS code.
108 * All other Catalog object creation should be done with the perl new() method.
109 */
110 SV*
111 new_catalog(uint32_t cat)
112 {
113 SV *iv, *ref;
115 iv = newSVuv(cat);
116 ref = newRV_noinc(iv);
117 sv_bless(ref, Sun_Solaris_Exacct_Catalog_stash);
118 SvREADONLY_on(iv);
119 return (ref);
120 }
122 /*
123 * Return the integer catalog value from the passed Catalog or IV.
124 * Calls croak() if the SV is not of the correct type.
125 */
126 ea_catalog_t
127 catalog_value(SV *catalog)
128 {
129 SV *sv;
131 /* If a reference, dereference and check it is a Catalog. */
132 if (SvROK(catalog)) {
133 sv = SvRV(catalog);
134 if (SvIOK(sv) &&
135 SvSTASH(sv) == Sun_Solaris_Exacct_Catalog_stash) {
136 return (SvIV(sv));
137 } else {
138 croak("Parameter is not a Catalog or integer");
139 }
141 /* For a plain IV, just return the value. */
142 } else if (SvIOK(catalog)) {
143 return (SvIV(catalog));
145 /* Anything else is an error */
146 } else {
147 croak("Parameter is not a Catalog or integer");
148 }
149 }
151 /*
152 * Return the string value of the id subfield of an ea_catalog_t.
153 */
154 char *
155 catalog_id_str(ea_catalog_t catalog)
156 {
157 static ea_catalog_t cat_val = ~0U;
158 static HV *cat_hash = NULL;
159 ea_catalog_t cat;
160 ea_catalog_t id;
161 char key[12]; /* Room for dec(2^32) digits. */
162 SV **svp;
164 cat = catalog & EXC_CATALOG_MASK;
165 id = catalog & EXD_DATA_MASK;
167 /* Fetch the correct id subhash if the catalog has changed. */
168 if (cat_val != cat) {
169 snprintf(key, sizeof (key), "%d", cat);
170 PERL_ASSERT(IdValueHash != NULL);
171 svp = hv_fetch(IdValueHash, key, strlen(key), FALSE);
172 if (svp == NULL) {
173 cat_val = ~0U;
174 cat_hash = NULL;
175 } else {
176 HV *hv;
178 cat_val = cat;
179 hv = (HV *)SvRV(*svp);
180 PERL_ASSERT(hv != NULL);
181 svp = hv_fetch(hv, "value", 5, FALSE);
182 PERL_ASSERT(svp != NULL);
183 cat_hash = (HV *)SvRV(*svp);
184 PERL_ASSERT(cat_hash != NULL);
185 }
186 }
188 /* If we couldn't find the hash, it is a catalog we don't know about. */
189 if (cat_hash == NULL) {
190 return ("UNKNOWN_ID");
191 }
193 /* Fetch the value from the selected catalog and return it. */
194 snprintf(key, sizeof (key), "%d", id);
195 svp = hv_fetch(cat_hash, key, strlen(key), TRUE);
196 if (svp == NULL) {
197 return ("UNKNOWN_ID");
198 }
199 return (SvPVX(*svp));
200 }
202 /*
203 * Create a new ::Object by wrapping an ea_object_t in a perl SV. This is used
204 * to wrap exacct records that have been read from a file, or packed records
205 * that have been inflated.
206 */
207 SV *
208 new_xs_ea_object(ea_object_t *ea_obj)
209 {
210 xs_ea_object_t *xs_obj;
211 SV *sv_obj;
213 /* Allocate space - use perl allocator. */
214 New(0, xs_obj, 1, xs_ea_object_t);
215 PERL_ASSERT(xs_obj != NULL);
216 xs_obj->ea_obj = ea_obj;
217 xs_obj->perl_obj = NULL;
218 sv_obj = NEWSV(0, 0);
219 PERL_ASSERT(sv_obj != NULL);
221 /*
222 * Initialise according to the type of the passed exacct object,
223 * and bless the perl object into the appropriate class.
224 */
225 if (ea_obj->eo_type == EO_ITEM) {
226 if ((ea_obj->eo_catalog & EXT_TYPE_MASK) == EXT_EXACCT_OBJECT) {
227 INIT_EMBED_ITEM_FLAGS(xs_obj);
228 } else {
229 INIT_PLAIN_ITEM_FLAGS(xs_obj);
230 }
231 sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj));
232 sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Item_stash);
233 } else {
234 INIT_GROUP_FLAGS(xs_obj);
235 sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj));
236 sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Group_stash);
237 }
239 /*
240 * We are passing back a pointer masquerading as a perl IV,
241 * so make sure it can't be modified.
242 */
243 SvREADONLY_on(SvRV(sv_obj));
244 return (sv_obj);
245 }
247 /*
248 * Convert the perl form of an ::Object into the corresponding exacct form.
249 * This is used prior to writing an ::Object to a file, or passing it to
250 * putacct. This is only required for embedded items and groups - for normal
251 * items it is a no-op.
252 */
253 ea_object_t *
254 deflate_xs_ea_object(SV *sv)
255 {
256 xs_ea_object_t *xs_obj;
257 ea_object_t *ea_obj;
259 /* Get the source xs_ea_object_t. */
260 PERL_ASSERT(sv != NULL);
261 sv = SvRV(sv);
262 PERL_ASSERT(sv != NULL);
263 xs_obj = INT2PTR(xs_ea_object_t *, SvIV(sv));
264 PERL_ASSERT(xs_obj != NULL);
265 ea_obj = xs_obj->ea_obj;
266 PERL_ASSERT(ea_obj != NULL);
268 /* Break any list this object is a part of. */
269 ea_obj->eo_next = NULL;
271 /* Deal with Items containing embedded Objects. */
272 if (IS_EMBED_ITEM(xs_obj)) {
273 xs_ea_object_t *child_xs_obj;
274 SV *perl_obj;
275 size_t bufsz;
277 /* Get the underlying perl object an deflate that in turn. */
278 perl_obj = xs_obj->perl_obj;
279 PERL_ASSERT(perl_obj != NULL);
280 deflate_xs_ea_object(perl_obj);
281 perl_obj = SvRV(perl_obj);
282 PERL_ASSERT(perl_obj != NULL);
283 child_xs_obj = INT2PTR(xs_ea_object_t *, SvIV(perl_obj));
284 PERL_ASSERT(child_xs_obj->ea_obj != NULL);
286 /* Free any existing object contents. */
287 if (ea_obj->eo_item.ei_object != NULL) {
288 ea_free(ea_obj->eo_item.ei_object,
289 ea_obj->eo_item.ei_size);
290 ea_obj->eo_item.ei_object = NULL;
291 ea_obj->eo_item.ei_size = 0;
292 }
294 /* Pack the object. */
295 while (1) {
296 /* Use the last buffer size as a best guess. */
297 if (last_bufsz != 0) {
298 ea_obj->eo_item.ei_object =
299 ea_alloc(last_bufsz);
300 PERL_ASSERT(ea_obj->eo_item.ei_object != NULL);
301 } else {
302 ea_obj->eo_item.ei_object = NULL;
303 }
305 /*
306 * Pack the object. If the buffer is too small,
307 * we will go around again with the correct size.
308 * If unsucessful, we will bail.
309 */
310 if ((bufsz = ea_pack_object(child_xs_obj->ea_obj,
311 ea_obj->eo_item.ei_object, last_bufsz)) == -1) {
312 ea_free(ea_obj->eo_item.ei_object, last_bufsz);
313 ea_obj->eo_item.ei_object = NULL;
314 return (NULL);
315 } else if (bufsz > last_bufsz) {
316 ea_free(ea_obj->eo_item.ei_object, last_bufsz);
317 last_bufsz = bufsz;
318 continue;
319 } else {
320 ea_obj->eo_item.ei_size = bufsz;
321 break;
322 }
323 }
325 /* Deal with Groups. */
326 } else if (IS_GROUP(xs_obj)) {
327 MAGIC *mg;
328 AV *av;
329 int len, i;
330 xs_ea_object_t *ary_xs;
331 ea_object_t *ary_ea, *prev_ea;
333 /* Find the AV underlying the tie. */
334 mg = mg_find(SvRV(xs_obj->perl_obj), 'P');
335 PERL_ASSERT(mg != NULL);
336 av = (AV*)SvRV(mg->mg_obj);
337 PERL_ASSERT(av != NULL);
339 /*
340 * Step along the AV, deflating each object and linking it into
341 * the exacct group item list.
342 */
343 prev_ea = ary_ea = NULL;
344 len = av_len(av) + 1;
345 ea_obj->eo_group.eg_nobjs = 0;
346 ea_obj->eo_group.eg_objs = NULL;
347 for (i = 0; i < len; i++) {
348 /*
349 * Get the source xs_ea_object_t. If the current slot
350 * in the array is empty, skip it.
351 */
352 SV **ary_svp;
353 if ((ary_svp = av_fetch(av, i, FALSE)) == NULL) {
354 continue;
355 }
356 PERL_ASSERT(*ary_svp != NULL);
358 /* Deflate it. */
359 ary_ea = deflate_xs_ea_object(*ary_svp);
360 PERL_ASSERT(ary_ea != NULL);
362 /* Link into the list. */
363 ary_ea->eo_next = NULL;
364 if (ea_obj->eo_group.eg_objs == NULL) {
365 ea_obj->eo_group.eg_objs = ary_ea;
366 }
367 ea_obj->eo_group.eg_nobjs++;
368 if (prev_ea != NULL) {
369 prev_ea->eo_next = ary_ea;
370 }
371 prev_ea = ary_ea;
372 }
373 }
374 return (ea_obj);
375 }
377 /*
378 * Private Sun::Solaris::Exacct utility code.
379 */
381 /*
382 * Return a string representation of an ea_error.
383 */
384 static const char *
385 error_str(int eno)
386 {
387 switch (eno) {
388 case EXR_OK:
389 return ("no error");
390 case EXR_SYSCALL_FAIL:
391 return ("system call failed");
392 case EXR_CORRUPT_FILE:
393 return ("corrupt file");
394 case EXR_EOF:
395 return ("end of file");
396 case EXR_NO_CREATOR:
397 return ("no creator");
398 case EXR_INVALID_BUF:
399 return ("invalid buffer");
400 case EXR_NOTSUPP:
401 return ("not supported");
402 case EXR_UNKN_VERSION:
403 return ("unknown version");
404 case EXR_INVALID_OBJ:
405 return ("invalid object");
406 default:
407 return ("unknown error");
408 }
409 }
411 /*
412 * The XS code exported to perl is below here. Note that the XS preprocessor
413 * has its own commenting syntax, so all comments from this point on are in
414 * that form.
415 */
417 MODULE = Sun::Solaris::Exacct PACKAGE = Sun::Solaris::Exacct
418 PROTOTYPES: ENABLE
420 #
421 # Define the stash pointers if required and create and populate @_Constants.
422 #
423 BOOT:
424 init_stashes();
425 define_constants(PKGBASE, constants);
427 #
428 # Return the last exacct error as a dual-typed SV. In a numeric context the
429 # SV will evaluate to the value of an EXR_* constant, in string context to a
430 # error message.
431 #
432 SV*
433 ea_error()
434 PREINIT:
435 int eno;
436 const char *msg;
437 CODE:
438 eno = ea_error();
439 msg = error_str(eno);
440 RETVAL = newSViv(eno);
441 sv_setpv(RETVAL, (char*) msg);
442 SvIOK_on(RETVAL);
443 OUTPUT:
444 RETVAL
446 #
447 # Return a string describing the last error to be encountered. If the value
448 # returned by ea_error is EXR_SYSCALL_FAIL, a string describing the value of
449 # errno will be returned. For all other values returned by ea_error() a string
450 # describing the exacct error will be returned.
451 #
452 char*
453 ea_error_str()
454 PREINIT:
455 int eno;
456 CODE:
457 eno = ea_error();
458 if (eno == EXR_SYSCALL_FAIL) {
459 RETVAL = strerror(errno);
460 if (RETVAL == NULL) {
461 RETVAL = "unknown system error";
462 }
463 } else {
464 RETVAL = (char*) error_str(eno);
465 }
466 OUTPUT:
467 RETVAL
469 #
470 # Return an accounting record for the specified task or process. idtype is
471 # either P_TASKID or P_PID and id is a process or task id.
472 #
473 SV*
474 getacct(idtype, id)
475 idtype_t idtype;
476 id_t id;
477 PREINIT:
478 int bufsz;
479 char *buf;
480 ea_object_t *ea_obj;
481 CODE:
482 /* Get the required accounting buffer. */
483 while (1) {
484 /* Use the last buffer size as a best guess. */
485 if (last_bufsz != 0) {
486 buf = ea_alloc(last_bufsz);
487 PERL_ASSERT(buf != NULL);
488 } else {
489 buf = NULL;
490 }
492 /*
493 * get the accounting record. If the buffer is too small,
494 * we will go around again with the correct size.
495 * If unsucessful, we will bail.
496 */
497 if ((bufsz = getacct(idtype, id, buf, last_bufsz)) == -1) {
498 if (last_bufsz != 0) {
499 ea_free(buf, last_bufsz);
500 }
501 XSRETURN_UNDEF;
502 } else if (bufsz > last_bufsz) {
503 ea_free(buf, last_bufsz);
504 last_bufsz = bufsz;
505 continue;
506 } else {
507 break;
508 }
509 }
511 /* Unpack the buffer. */
512 if (ea_unpack_object(&ea_obj, EUP_ALLOC, buf, bufsz) == -1) {
513 ea_free(buf, last_bufsz);
514 XSRETURN_UNDEF;
515 }
516 ea_free(buf, last_bufsz);
517 RETVAL = new_xs_ea_object(ea_obj);
518 OUTPUT:
519 RETVAL
521 #
522 # Write an accounting record into the system accounting file. idtype is
523 # either P_TASKID or P_PID and id is a process or task id. value may be either
524 # an ::Exacct::Object, in which case it will be packed and inserted in the
525 # file, or a SV which will be converted to a string and inserted into the file.
526 #
527 SV*
528 putacct(idtype, id, value)
529 idtype_t idtype;
530 id_t id;
531 SV *value;
532 PREINIT:
533 HV *stash;
534 STRLEN bufsz;
535 int flags, ret;
536 char *buf;
537 CODE:
538 /* If it is an ::Object::Item or ::Object::Group, pack it. */
539 stash = SvROK(value) ? SvSTASH(SvRV(value)) : NULL;
540 if (stash == Sun_Solaris_Exacct_Object_Item_stash ||
541 stash == Sun_Solaris_Exacct_Object_Group_stash) {
542 ea_object_t *obj;
544 /* Deflate the object. */
545 if ((obj = deflate_xs_ea_object(value)) == NULL) {
546 XSRETURN_NO;
547 }
549 /* Pack the object. */
550 while (1) {
551 /* Use the last buffer size as a best guess. */
552 if (last_bufsz != 0) {
553 buf = ea_alloc(last_bufsz);
554 PERL_ASSERT(buf != NULL);
555 } else {
556 buf = NULL;
557 }
559 /*
560 * Pack the object. If the buffer is too small, we
561 * will go around again with the correct size.
562 * If unsucessful, we will bail.
563 */
564 if ((bufsz = ea_pack_object(obj, buf, last_bufsz))
565 == -1) {
566 if (last_bufsz != 0) {
567 ea_free(buf, last_bufsz);
568 }
569 XSRETURN_NO;
570 } else if (bufsz > last_bufsz) {
571 ea_free(buf, last_bufsz);
572 last_bufsz = bufsz;
573 continue;
574 } else {
575 break;
576 }
577 }
578 flags = EP_EXACCT_OBJECT;
580 /* Otherwise treat it as normal SV - convert to a string. */
581 } else {
582 buf = SvPV(value, bufsz);
583 flags = EP_RAW;
584 }
586 /* Call putacct to write the buffer */
587 RETVAL = putacct(idtype, id, buf, bufsz, flags) == 0
588 ? &PL_sv_yes : &PL_sv_no;
590 /* Clean up if we allocated a buffer. */
591 if (flags == EP_EXACCT_OBJECT) {
592 ea_free(buf, last_bufsz);
593 }
594 OUTPUT:
595 RETVAL
597 #
598 # Write an accounting record for the specified task or process. idtype is
599 # either P_TASKID or P_PID, id is a process or task id and flags is either
600 # EW_PARTIAL or EW_INTERVAL.
601 #
602 int
603 wracct(idtype, id, flags)
604 idtype_t idtype;
605 id_t id;
606 int flags;