Mercurial > illumos > illumos-gate
view usr/src/cmd/perl/contrib/Sun/Solaris/Exacct/Exacct.xs @ 13672:bc588248a482
2636 Perl bits do not compile cleanly under 64bit perl
Reviewed by: Richard Lowe <richlowe@richlowe.net>
Reviewed by: Robert Mustacchi <rm@joyent.com>
Approved by: Richard Lowe <richlowe@richlowe.net>
author | Theo Schlossnagle <jesus@omniti.com> |
---|---|
date | Wed, 18 Apr 2012 22:20:23 +0000 |
parents | 1bc8d55b0dfd |
children |
line wrap: on
line source
/* * Copyright (c) 2002, Oracle and/or its affiliates. All rights reserved. * * Exacct.xs contains XS code for creating various exacct-related constants, * and for providing wrappers around exacct error handling and * accounting-related system calls. It also contains commonly-used utility * code shared by its sub-modules. */ #include <string.h> #include "exacct_common.xh" /* * Pull in the file generated by extract_defines. This contains a table * of numeric constants and their string equivalents which have been extracted * from the various exacct header files by the extract_defines script. */ #include "ExacctDefs.xi" /* * Object stash pointers - caching these speeds up the creation and * typechecking of perl objects by removing the need to do a hash lookup. * The peculiar variable names are so that typemaps can generate the correct * package name using the typemap '$Package' variable as the root of the name. */ HV *Sun_Solaris_Exacct_Catalog_stash; HV *Sun_Solaris_Exacct_File_stash; HV *Sun_Solaris_Exacct_Object_Item_stash; HV *Sun_Solaris_Exacct_Object_Group_stash; HV *Sun_Solaris_Exacct_Object__Array_stash; /* * Pointer to part of the hash tree built by define_catalog_constants in * Catalog.xs. This is used by catalog_id_str() when mapping from a catalog * to an id string. */ HV *IdValueHash = NULL; /* * Last buffer size used for packing and unpacking exacct objects. */ static int last_bufsz = 0; /* * Common utility code. This is placed here instead of in the sub-modules to * reduce the number of cross-module linker dependencies that are required, * although most of the code more properly belongs in the sub-modules. */ /* * This function populates the various stash pointers used by the ::Exacct * module. It is called from each of the module BOOT sections to ensure the * stash pointers are initialised on startup. */ void init_stashes(void) { if (Sun_Solaris_Exacct_Catalog_stash == NULL) { Sun_Solaris_Exacct_Catalog_stash = gv_stashpv(PKGBASE "::Catalog", TRUE); Sun_Solaris_Exacct_File_stash = gv_stashpv(PKGBASE "::File", TRUE); Sun_Solaris_Exacct_Object_Item_stash = gv_stashpv(PKGBASE "::Object::Item", TRUE); Sun_Solaris_Exacct_Object_Group_stash = gv_stashpv(PKGBASE "::Object::Group", TRUE); Sun_Solaris_Exacct_Object__Array_stash = gv_stashpv(PKGBASE "::Object::_Array", TRUE); } } /* * This function populates the @_Constants array in the specified package * based on the values extracted from the exacct header files by the * extract_defines script and written to the .xi file which is included above. * It also creates a const sub for each constant that returns the associcated * value. It should be called from the BOOT sections of modules that export * constants. */ #define CONST_NAME "::_Constants" void define_constants(const char *pkg, constval_t *cvp) { HV *stash; char *name; AV *constants; /* Create the new perl @_Constants variable. */ stash = gv_stashpv(pkg, TRUE); name = New(0, name, strlen(pkg) + sizeof (CONST_NAME), char); PERL_ASSERT(name != NULL); strcpy(name, pkg); strcat(name, CONST_NAME); constants = perl_get_av(name, TRUE); Safefree(name); /* Populate @_Constants from the contents of the generated array. */ for (; cvp->name != NULL; cvp++) { newCONSTSUB(stash, (char *)cvp->name, newSVuv(cvp->value)); av_push(constants, newSVpvn((char *)cvp->name, cvp->len)); } } #undef CONST_NAME /* * Return a new Catalog object - only accepts an integer catalog value. * Use this purely for speed when creating Catalog objects from other XS code. * All other Catalog object creation should be done with the perl new() method. */ SV* new_catalog(uint32_t cat) { SV *iv, *ref; iv = newSVuv(cat); ref = newRV_noinc(iv); sv_bless(ref, Sun_Solaris_Exacct_Catalog_stash); SvREADONLY_on(iv); return (ref); } /* * Return the integer catalog value from the passed Catalog or IV. * Calls croak() if the SV is not of the correct type. */ ea_catalog_t catalog_value(SV *catalog) { SV *sv; /* If a reference, dereference and check it is a Catalog. */ if (SvROK(catalog)) { sv = SvRV(catalog); if (SvIOK(sv) && SvSTASH(sv) == Sun_Solaris_Exacct_Catalog_stash) { return (SvIV(sv)); } else { croak("Parameter is not a Catalog or integer"); } /* For a plain IV, just return the value. */ } else if (SvIOK(catalog)) { return (SvIV(catalog)); /* Anything else is an error */ } else { croak("Parameter is not a Catalog or integer"); } } /* * Return the string value of the id subfield of an ea_catalog_t. */ char * catalog_id_str(ea_catalog_t catalog) { static ea_catalog_t cat_val = ~0U; static HV *cat_hash = NULL; ea_catalog_t cat; ea_catalog_t id; char key[12]; /* Room for dec(2^32) digits. */ SV **svp; cat = catalog & EXC_CATALOG_MASK; id = catalog & EXD_DATA_MASK; /* Fetch the correct id subhash if the catalog has changed. */ if (cat_val != cat) { snprintf(key, sizeof (key), "%d", cat); PERL_ASSERT(IdValueHash != NULL); svp = hv_fetch(IdValueHash, key, strlen(key), FALSE); if (svp == NULL) { cat_val = ~0U; cat_hash = NULL; } else { HV *hv; cat_val = cat; hv = (HV *)SvRV(*svp); PERL_ASSERT(hv != NULL); svp = hv_fetch(hv, "value", 5, FALSE); PERL_ASSERT(svp != NULL); cat_hash = (HV *)SvRV(*svp); PERL_ASSERT(cat_hash != NULL); } } /* If we couldn't find the hash, it is a catalog we don't know about. */ if (cat_hash == NULL) { return ("UNKNOWN_ID"); } /* Fetch the value from the selected catalog and return it. */ snprintf(key, sizeof (key), "%d", id); svp = hv_fetch(cat_hash, key, strlen(key), TRUE); if (svp == NULL) { return ("UNKNOWN_ID"); } return (SvPVX(*svp)); } /* * Create a new ::Object by wrapping an ea_object_t in a perl SV. This is used * to wrap exacct records that have been read from a file, or packed records * that have been inflated. */ SV * new_xs_ea_object(ea_object_t *ea_obj) { xs_ea_object_t *xs_obj; SV *sv_obj; /* Allocate space - use perl allocator. */ New(0, xs_obj, 1, xs_ea_object_t); PERL_ASSERT(xs_obj != NULL); xs_obj->ea_obj = ea_obj; xs_obj->perl_obj = NULL; sv_obj = NEWSV(0, 0); PERL_ASSERT(sv_obj != NULL); /* * Initialise according to the type of the passed exacct object, * and bless the perl object into the appropriate class. */ if (ea_obj->eo_type == EO_ITEM) { if ((ea_obj->eo_catalog & EXT_TYPE_MASK) == EXT_EXACCT_OBJECT) { INIT_EMBED_ITEM_FLAGS(xs_obj); } else { INIT_PLAIN_ITEM_FLAGS(xs_obj); } sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj)); sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Item_stash); } else { INIT_GROUP_FLAGS(xs_obj); sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj)); sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Group_stash); } /* * We are passing back a pointer masquerading as a perl IV, * so make sure it can't be modified. */ SvREADONLY_on(SvRV(sv_obj)); return (sv_obj); } /* * Convert the perl form of an ::Object into the corresponding exacct form. * This is used prior to writing an ::Object to a file, or passing it to * putacct. This is only required for embedded items and groups - for normal * items it is a no-op. */ ea_object_t * deflate_xs_ea_object(SV *sv) { xs_ea_object_t *xs_obj; ea_object_t *ea_obj; /* Get the source xs_ea_object_t. */ PERL_ASSERT(sv != NULL); sv = SvRV(sv); PERL_ASSERT(sv != NULL); xs_obj = INT2PTR(xs_ea_object_t *, SvIV(sv)); PERL_ASSERT(xs_obj != NULL); ea_obj = xs_obj->ea_obj; PERL_ASSERT(ea_obj != NULL); /* Break any list this object is a part of. */ ea_obj->eo_next = NULL; /* Deal with Items containing embedded Objects. */ if (IS_EMBED_ITEM(xs_obj)) { xs_ea_object_t *child_xs_obj; SV *perl_obj; size_t bufsz; /* Get the underlying perl object an deflate that in turn. */ perl_obj = xs_obj->perl_obj; PERL_ASSERT(perl_obj != NULL); deflate_xs_ea_object(perl_obj); perl_obj = SvRV(perl_obj); PERL_ASSERT(perl_obj != NULL); child_xs_obj = INT2PTR(xs_ea_object_t *, SvIV(perl_obj)); PERL_ASSERT(child_xs_obj->ea_obj != NULL); /* Free any existing object contents. */ if (ea_obj->eo_item.ei_object != NULL) { ea_free(ea_obj->eo_item.ei_object, ea_obj->eo_item.ei_size); ea_obj->eo_item.ei_object = NULL; ea_obj->eo_item.ei_size = 0; } /* Pack the object. */ while (1) { /* Use the last buffer size as a best guess. */ if (last_bufsz != 0) { ea_obj->eo_item.ei_object = ea_alloc(last_bufsz); PERL_ASSERT(ea_obj->eo_item.ei_object != NULL); } else { ea_obj->eo_item.ei_object = NULL; } /* * Pack the object. If the buffer is too small, * we will go around again with the correct size. * If unsucessful, we will bail. */ if ((bufsz = ea_pack_object(child_xs_obj->ea_obj, ea_obj->eo_item.ei_object, last_bufsz)) == -1) { ea_free(ea_obj->eo_item.ei_object, last_bufsz); ea_obj->eo_item.ei_object = NULL; return (NULL); } else if (bufsz > last_bufsz) { ea_free(ea_obj->eo_item.ei_object, last_bufsz); last_bufsz = bufsz; continue; } else { ea_obj->eo_item.ei_size = bufsz; break; } } /* Deal with Groups. */ } else if (IS_GROUP(xs_obj)) { MAGIC *mg; AV *av; int len, i; xs_ea_object_t *ary_xs; ea_object_t *ary_ea, *prev_ea; /* Find the AV underlying the tie. */ mg = mg_find(SvRV(xs_obj->perl_obj), 'P'); PERL_ASSERT(mg != NULL); av = (AV*)SvRV(mg->mg_obj); PERL_ASSERT(av != NULL); /* * Step along the AV, deflating each object and linking it into * the exacct group item list. */ prev_ea = ary_ea = NULL; len = av_len(av) + 1; ea_obj->eo_group.eg_nobjs = 0; ea_obj->eo_group.eg_objs = NULL; for (i = 0; i < len; i++) { /* * Get the source xs_ea_object_t. If the current slot * in the array is empty, skip it. */ SV **ary_svp; if ((ary_svp = av_fetch(av, i, FALSE)) == NULL) { continue; } PERL_ASSERT(*ary_svp != NULL); /* Deflate it. */ ary_ea = deflate_xs_ea_object(*ary_svp); PERL_ASSERT(ary_ea != NULL); /* Link into the list. */ ary_ea->eo_next = NULL; if (ea_obj->eo_group.eg_objs == NULL) { ea_obj->eo_group.eg_objs = ary_ea; } ea_obj->eo_group.eg_nobjs++; if (prev_ea != NULL) { prev_ea->eo_next = ary_ea; } prev_ea = ary_ea; } } return (ea_obj); } /* * Private Sun::Solaris::Exacct utility code. */ /* * Return a string representation of an ea_error. */ static const char * error_str(int eno) { switch (eno) { case EXR_OK: return ("no error"); case EXR_SYSCALL_FAIL: return ("system call failed"); case EXR_CORRUPT_FILE: return ("corrupt file"); case EXR_EOF: return ("end of file"); case EXR_NO_CREATOR: return ("no creator"); case EXR_INVALID_BUF: return ("invalid buffer"); case EXR_NOTSUPP: return ("not supported"); case EXR_UNKN_VERSION: return ("unknown version"); case EXR_INVALID_OBJ: return ("invalid object"); default: return ("unknown error"); } } /* * The XS code exported to perl is below here. Note that the XS preprocessor * has its own commenting syntax, so all comments from this point on are in * that form. */ MODULE = Sun::Solaris::Exacct PACKAGE = Sun::Solaris::Exacct PROTOTYPES: ENABLE # # Define the stash pointers if required and create and populate @_Constants. # BOOT: init_stashes(); define_constants(PKGBASE, constants); # # Return the last exacct error as a dual-typed SV. In a numeric context the # SV will evaluate to the value of an EXR_* constant, in string context to a # error message. # SV* ea_error() PREINIT: int eno; const char *msg; CODE: eno = ea_error(); msg = error_str(eno); RETVAL = newSViv(eno); sv_setpv(RETVAL, (char*) msg); SvIOK_on(RETVAL); OUTPUT: RETVAL # # Return a string describing the last error to be encountered. If the value # returned by ea_error is EXR_SYSCALL_FAIL, a string describing the value of # errno will be returned. For all other values returned by ea_error() a string # describing the exacct error will be returned. # char* ea_error_str() PREINIT: int eno; CODE: eno = ea_error(); if (eno == EXR_SYSCALL_FAIL) { RETVAL = strerror(errno); if (RETVAL == NULL) { RETVAL = "unknown system error"; } } else { RETVAL = (char*) error_str(eno); } OUTPUT: RETVAL # # Return an accounting record for the specified task or process. idtype is # either P_TASKID or P_PID and id is a process or task id. # SV* getacct(idtype, id) idtype_t idtype; id_t id; PREINIT: int bufsz; char *buf; ea_object_t *ea_obj; CODE: /* Get the required accounting buffer. */ while (1) { /* Use the last buffer size as a best guess. */ if (last_bufsz != 0) { buf = ea_alloc(last_bufsz); PERL_ASSERT(buf != NULL); } else { buf = NULL; } /* * get the accounting record. If the buffer is too small, * we will go around again with the correct size. * If unsucessful, we will bail. */ if ((bufsz = getacct(idtype, id, buf, last_bufsz)) == -1) { if (last_bufsz != 0) { ea_free(buf, last_bufsz); } XSRETURN_UNDEF; } else if (bufsz > last_bufsz) { ea_free(buf, last_bufsz); last_bufsz = bufsz; continue; } else { break; } } /* Unpack the buffer. */ if (ea_unpack_object(&ea_obj, EUP_ALLOC, buf, bufsz) == -1) { ea_free(buf, last_bufsz); XSRETURN_UNDEF; } ea_free(buf, last_bufsz); RETVAL = new_xs_ea_object(ea_obj); OUTPUT: RETVAL # # Write an accounting record into the system accounting file. idtype is # either P_TASKID or P_PID and id is a process or task id. value may be either # an ::Exacct::Object, in which case it will be packed and inserted in the # file, or a SV which will be converted to a string and inserted into the file. # SV* putacct(idtype, id, value) idtype_t idtype; id_t id; SV *value; PREINIT: HV *stash; STRLEN bufsz; int flags, ret; char *buf; CODE: /* If it is an ::Object::Item or ::Object::Group, pack it. */ stash = SvROK(value) ? SvSTASH(SvRV(value)) : NULL; if (stash == Sun_Solaris_Exacct_Object_Item_stash || stash == Sun_Solaris_Exacct_Object_Group_stash) { ea_object_t *obj; /* Deflate the object. */ if ((obj = deflate_xs_ea_object(value)) == NULL) { XSRETURN_NO; } /* Pack the object. */ while (1) { /* Use the last buffer size as a best guess. */ if (last_bufsz != 0) { buf = ea_alloc(last_bufsz); PERL_ASSERT(buf != NULL); } else { buf = NULL; } /* * Pack the object. If the buffer is too small, we * will go around again with the correct size. * If unsucessful, we will bail. */ if ((bufsz = ea_pack_object(obj, buf, last_bufsz)) == -1) { if (last_bufsz != 0) { ea_free(buf, last_bufsz); } XSRETURN_NO; } else if (bufsz > last_bufsz) { ea_free(buf, last_bufsz); last_bufsz = bufsz; continue; } else { break; } } flags = EP_EXACCT_OBJECT; /* Otherwise treat it as normal SV - convert to a string. */ } else { buf = SvPV(value, bufsz); flags = EP_RAW; } /* Call putacct to write the buffer */ RETVAL = putacct(idtype, id, buf, bufsz, flags) == 0 ? &PL_sv_yes : &PL_sv_no; /* Clean up if we allocated a buffer. */ if (flags == EP_EXACCT_OBJECT) { ea_free(buf, last_bufsz); } OUTPUT: RETVAL # # Write an accounting record for the specified task or process. idtype is # either P_TASKID or P_PID, id is a process or task id and flags is either # EW_PARTIAL or EW_INTERVAL. # int wracct(idtype, id, flags) idtype_t idtype; id_t id; int flags;