Object.xs revision 7c478bd95313f5f23a4c958a745db2134aa03244
/*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at usr/src/OPENSOLARIS.LICENSE.
* If applicable, add the following below this CDDL HEADER, with the
* fields enclosed by brackets "[]" replaced with your own identifying
* information: Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*/
/*
* Copyright 2002-2003 Sun Microsystems, Inc. All rights reserved.
* Use is subject to license terms.
*
* Object.xs contains XS code for exacct file manipulation.
*/
#pragma ident "%Z%%M% %I% %E% SMI"
#include <strings.h>
#include "../exacct_common.xh"
/* Pull in the file generated by extract_defines. */
#include "ObjectDefs.xi"
/* From Catalog.xs. */
/*
* Copy an xs_ea_object_t. If the perl_obj part is null, we just copy the
* ea_object_t part. If the perl_obj part is not null and the Object is an
* Item it must be because the Item contains an embedded Object, which will be
* recursively copied. Otherwise the Object must be a Group, so the Group will
* be copied, and the list of Objects it contains will be recursively copied.
*/
static SV *
{
/* Get the source xs_ea_object_t and make a new one. */
/* If the Object is a plain Item only the ea_obj part needs copying. */
if (IS_PLAIN_ITEM(src)) {
/*
* Otherwise if it is an Item with a perl_obj part, it means that it
* must be an Item containing an unpacked nested Object. In this case
* the nested Object can be copied by a recursive call.
*/
} else if (IS_EMBED_ITEM(src)) {
/*
* If we get here it must be a Group, so perl_obj will point to a tied
* AV. We therefore copy the exacct part then create a new tied array
* and recursively copy each Item individually.
*/
} else {
int i, len;
/* Copy the exacct part of the Group. */
/* Find the AV underlying the tie. */
/* Create a new AV and copy across into it. */
for (i = 0; i < len; i++) {
/* undef elements don't need copying. */
}
}
}
/* Create a new AV and tie the filled AV to it. */
}
/* Wrap the new xs_ea_object_t in a blessed RV and return it. */
return (dst_rv);
}
/*
* If an ea_xs_object_t only has the ea_obj part populated, create the
* corresponding perl_obj part. For plain Items this is a no-op. If the
* object is embedded, the embedded part will be unpacked and stored in the
* perl part. If the object is a Group, the linked list of Items will be
* wrapped in the corresponding perl structure and stored in a tied perl array.
*/
static int
{
/* Check there is not already a perl_obj part. */
/* Deal with Items containing embedded Objects. */
if (IS_EMBED_ITEM(xs_obj)) {
/* unpack & wrap in an xs_ea_object_t. */
return (0);
}
/* Deal with Groups. */
int i, len;
/* Create a new array. */
/* Copy each object from the old array into the new array. */
for (i = 0; i < len; i++) {
}
}
/* Create a new AV and tie the filled AV to it. */
}
return (1);
}
/*
* 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.
*/
#
#
BOOT:
{
init_stashes();
}
#
#
SV *
CODE:
case EO_ITEM:
break;
case EO_GROUP:
break;
case EO_NONE:
default:
break;
}
#
#
SV *
CODE:
#
#
void
/*
* For Items, return the perl representation
* of the underlying ea_object_t.
*/
case EXT_UINT8:
break;
case EXT_UINT16:
break;
case EXT_UINT32:
break;
case EXT_UINT64:
break;
case EXT_DOUBLE:
break;
case EXT_STRING:
break;
case EXT_RAW:
break;
/*
* For embedded objects and Groups, return a ref to the perl SV.
*/
case EXT_EXACCT_OBJECT:
/* Make sure the object is inflated. */
if (! inflate_xs_ea_object(self)) {
}
}
break;
case EXT_GROUP:
break;
case EXT_NONE:
default:
croak("Invalid object type");
break;
}
/*
* Now we deal with Groups.
*/
} else {
/* Make sure the object is inflated. */
if (! inflate_xs_ea_object(self)) {
}
}
/* In a list context return the contents of the AV. */
int len, i;
/* Find the AV underlying the tie. */
/*
* Push the contents of the array onto the stack.
* Push undef for any empty array slots.
*/
for (i = 0; i < len; i++) {
PUSHs(&PL_sv_undef);
} else {
}
}
/* In a scalar context, return a ref to the array of Items. */
} else {
}
}
#
#
int
CODE:
#
#
void
CODE:
/*
* Because both libexacct and perl know about the ea_object_t, we have
* to make sure that they don't both end up freeing the object. First
* we break any link to the next ea_object_t in the chain. Next, if
* the object is a Group and there is an active perl_obj chain, we will
* let perl clean up the Objects, so we zero the eo_group chain.
*/
}
}
#
#
char *class;
CODE:
/* Create a new xs_ea_object_t and subsiduary structures. */
/* Assign the Item's value. */
case EXT_UINT8:
break;
case EXT_UINT16:
break;
case EXT_UINT32:
break;
case EXT_UINT64:
break;
case EXT_DOUBLE:
break;
case EXT_STRING:
break;
case EXT_RAW:
break;
case EXT_EXACCT_OBJECT:
/*
* The ea_obj part is initially empty, and will be populated
* from the perl_obj part when required.
*/
if (stash != Sun_Solaris_Exacct_Object_Item_stash &&
}
break;
/*
* EXT_NONE is an invalid type,
* EXT_GROUP is created by the Group subclass constructor.
*/
case EXT_NONE:
case EXT_GROUP:
default:
croak("Invalid object type");
break;
}
char *class;
int i;
CODE:
croak("Invalid object type");
}
/* Create a new xs_ea_object_t and subsiduary structures. */
/* Create a new AV and copy in all the passed Items. */
for (i = 2; i < items; i++) {
if (stash != Sun_Solaris_Exacct_Object_Item_stash &&
}
}
/* Bless the copied AV and tie it to a new AV */
#
# item's catalog id as the key. There are two forms - as_hash() which stores
# each hash value as a scalar, and should be used when it is known the group
# does not contain duplicate catalog tags, and as_hashlist wich stores each
# hash value as an array of values, and can therefore be used when the group
# may contain duplicate catalog tags.
#
SV *
as_hash(self)
xs_ea_object_t *self;
ALIAS:
as_hashlist = 1
PREINIT:
MAGIC *mg;
HV *hv;
AV *av;
int len, i;
CODE:
/* Make sure the object is inflated. */
if (self->perl_obj == NULL) {
if (! inflate_xs_ea_object(self)) {
XSRETURN_UNDEF;
}
}
/* Find the AV underlying the tie and create the new HV. */
mg = mg_find(SvRV(self->perl_obj), 'P');
PERL_ASSERT(mg != NULL);
av = (AV *)SvRV(mg->mg_obj);
PERL_ASSERT(av != NULL);
hv = newHV();
/*
* Traverse the value array, saving the values in the hash,
* keyed by the string value of the catalog id field.
*/
len = av_len(av) + 1;
for (i = 0; i < len; i++) {
SV **svp, *val;
xs_ea_object_t *xs_obj;
const char *key;
/* Ignore undef values. */
if ((svp = av_fetch(av, i, FALSE)) == NULL) {
continue;
}
PERL_ASSERT(*svp != NULL);
/* Figure out the key. */
xs_obj = INT2PTR(xs_ea_object_t *, SvIV(SvRV(*svp)));
key = catalog_id_str(xs_obj->ea_obj->eo_catalog);
/*
* For Items, save the perl representation
* of the underlying ea_object_t.
*/
if (IS_ITEM(xs_obj)) {
switch (xs_obj->ea_obj->eo_catalog & EXT_TYPE_MASK) {
case EXT_UINT8:
val =
newSVuv(xs_obj->ea_obj->eo_item.ei_uint8);
break;
case EXT_UINT16:
val =
newSVuv(xs_obj->ea_obj->eo_item.ei_uint16);
break;
case EXT_UINT32:
val =
newSVuv(xs_obj->ea_obj->eo_item.ei_uint32);
break;
case EXT_UINT64:
val =
newSVuv(xs_obj->ea_obj->eo_item.ei_uint64);
break;
case EXT_DOUBLE:
val =
newSVnv(xs_obj->ea_obj->eo_item.ei_double);
break;
case EXT_STRING:
val =
newSVpvn(xs_obj->ea_obj->eo_item.ei_string,
xs_obj->ea_obj->eo_item.ei_size - 1);
break;
case EXT_RAW:
val =
newSVpvn(xs_obj->ea_obj->eo_item.ei_raw,
xs_obj->ea_obj->eo_item.ei_size);
break;
/*
* For embedded objects and Groups, return a ref
* to the perl SV.
*/
case EXT_EXACCT_OBJECT:
if (xs_obj->perl_obj == NULL) {
/* Make sure the object is inflated. */
if (! inflate_xs_ea_object(xs_obj)) {
SvREFCNT_dec(hv);
XSRETURN_UNDEF;
}
}
val = SvREFCNT_inc(xs_obj->perl_obj);
break;
case EXT_GROUP:
val = SvREFCNT_inc(xs_obj->perl_obj);
break;
case EXT_NONE:
default:
croak("Invalid object type");
break;
}
/*
* Now we deal with Groups.
*/
} else {
/* Make sure the object is inflated. */
if (xs_obj->perl_obj == NULL) {
if (! inflate_xs_ea_object(xs_obj)) {
SvREFCNT_dec(hv);
XSRETURN_UNDEF;
}
}
val = SvREFCNT_inc(xs_obj->perl_obj);
}
/*
* If called as as_hash(), store the value directly in the
* hash, if called as as_hashlist(), store the value in an
* array within the hash.
*/
if (ix == 0) {
hv_store(hv, key, strlen(key), val, FALSE);
} else {
AV *ary;
/* If the key already exists in the hash. */
svp = hv_fetch(hv, key, strlen(key), TRUE);
if (SvOK(*svp)) {
ary = (AV *)SvRV(*svp);
/* Otherwise, add a new array to the hash. */
} else {
SV *rv;
ary = newAV();
rv = newRV_noinc((SV *)ary);
sv_setsv(*svp, rv);
SvREFCNT_dec(rv);
}
av_push(ary, val);
}
}
RETVAL = newRV_noinc((SV *)hv);
OUTPUT:
RETVAL
MODULE = Sun::Solaris::Exacct::Object PACKAGE = Sun::Solaris::Exacct::Object::_Array
PROTOTYPES: ENABLE
#
# Copy the passed list of xs_ea_object_t.
#
void
copy_xs_ea_objects(...)
PREINIT:
int i;
PPCODE:
EXTEND(SP, items);
for (i = 0; i < items; i++) {
HV *stash;
stash = SvROK(ST(i)) ? SvSTASH(SvRV(ST(i))) : NULL;
if (stash != Sun_Solaris_Exacct_Object_Item_stash &&
stash != Sun_Solaris_Exacct_Object_Group_stash) {
croak("item is not of type " PKGBASE "::Object");
}
PUSHs(sv_2mortal(copy_xs_ea_object(ST(i))));
}