view release on metacpan or  search on metacpan

Object/Object.xs  view on Meta::CPAN

/*
 * 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	"@(#)Object.xs	1.2	03/03/13 SMI"

#include <strings.h>
#include "../exacct_common.xh"

/* Pull in the file generated by extract_defines. */
#include "ObjectDefs.xi"

/* From Catalog.xs. */
extern char *catalog_id_str(ea_catalog_t catalog);

/*
 * 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 *
copy_xs_ea_object(SV *src_sv)
{
	xs_ea_object_t	*src, *dst;
	SV		*dst_sv, *dst_rv;

	/* Get the source xs_ea_object_t and make a new one. */
	PERL_ASSERT(src_sv != NULL);
	src_sv = SvRV(src_sv);
	PERL_ASSERT(src_sv != NULL);
	src = INT2PTR(xs_ea_object_t *, SvIV(src_sv));
	PERL_ASSERT(src != NULL);
	New(0, dst, 1, xs_ea_object_t);
	dst->flags = src->flags;

	/* If the Object is a plain Item only the ea_obj part needs copying. */
	if (IS_PLAIN_ITEM(src)) {
		dst->ea_obj = ea_copy_object_tree(src->ea_obj);
		PERL_ASSERT(dst->ea_obj != NULL);
		dst->perl_obj = NULL;

	/*
	 * 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)) {
		dst->ea_obj = ea_copy_object(src->ea_obj);
		PERL_ASSERT(dst->ea_obj != NULL);
		dst->perl_obj = copy_xs_ea_object(src->perl_obj);

	/*
	 * 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 {
		MAGIC	*mg;
		AV	*src_av, *dst_av, *tied_av;
		SV	*sv;
		int	i, len;

		/* Copy the exacct part of the Group. */
		dst->ea_obj = ea_copy_object(src->ea_obj);
		PERL_ASSERT(dst->ea_obj != NULL);

		/* Find the AV underlying the tie. */
		mg = mg_find(SvRV(src->perl_obj), 'P');
		PERL_ASSERT(mg != NULL);
		src_av = (AV *)SvRV(mg->mg_obj);
		PERL_ASSERT(src_av != NULL);

		/* Create a new AV and copy across into it. */
		dst_av = newAV();
		len = av_len(src_av) + 1;
		av_extend(dst_av, len);
		for (i = 0; i < len; i++) {
			SV **svp;

			/* undef elements don't need copying. */
			if ((svp = av_fetch(src_av, i, FALSE)) != NULL) {
				sv = copy_xs_ea_object(*svp);
				if (av_store(dst_av, i, sv) == NULL) {
					SvREFCNT_dec(sv);
				}
			}
		}

		/* Create a new AV and tie the filled AV to it. */
		sv = newRV_noinc((SV *)dst_av);
		sv_bless(sv, Sun_Solaris_Exacct_Object__Array_stash);
		tied_av = newAV();
		sv_magic((SV *)tied_av, sv, 'P', Nullch, 0);
		SvREFCNT_dec(sv);
		dst->perl_obj = newRV_noinc((SV *)tied_av);
	}

	/* Wrap the new xs_ea_object_t in a blessed RV and return it.  */
	dst_sv = newSViv(PTR2IV(dst));
	dst_rv = newRV_noinc(dst_sv);
	sv_bless(dst_rv, SvSTASH(src_sv));
	SvREADONLY_on(dst_sv);
	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
inflate_xs_ea_object(xs_ea_object_t *xs_obj)
{
	ea_object_t	*ea_obj;

	/* Check there is not already a perl_obj part. */
	PERL_ASSERT(xs_obj != NULL);
	PERL_ASSERT(xs_obj->perl_obj == NULL);

	/* Deal with Items containing embedded Objects. */
	if (IS_EMBED_ITEM(xs_obj)) {
		/* unpack & wrap in an xs_ea_object_t. */
		if (ea_unpack_object(&ea_obj, EUP_ALLOC,
		    xs_obj->ea_obj->eo_item.ei_object,
		    xs_obj->ea_obj->eo_item.ei_size) == -1) {
			return (0);
		}
		xs_obj->perl_obj = new_xs_ea_object(ea_obj);

	/* Deal with Groups. */
	} else if (IS_GROUP(xs_obj)) {
		int	i, len;
		AV	*av, *tied_av;
		SV	*rv, *sv;

		/* Create a new array. */
		av = newAV();
		ea_obj = xs_obj->ea_obj;
		len = ea_obj->eo_group.eg_nobjs;
		ea_obj = ea_obj->eo_group.eg_objs;

		/* Copy each object from the old array into the new array. */
		for (i = 0; i < len; i++) {
			rv = new_xs_ea_object(ea_obj);
			if (av_store(av, i, rv) == NULL) {
				SvREFCNT_dec(rv);
			}
			ea_obj = ea_obj->eo_next;
		}

		/* Create a new AV and tie the filled AV to it. */
		rv = newRV_noinc((SV *)av);
		sv_bless(rv, Sun_Solaris_Exacct_Object__Array_stash);
		tied_av = newAV();
		sv_magic((SV *)tied_av, rv, 'P', Nullch, 0);
		SvREFCNT_dec(rv);
		xs_obj->perl_obj = newRV_noinc((SV *)tied_av);
	}
	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.
 */

MODULE = Sun::Solaris::Exacct::Object PACKAGE = Sun::Solaris::Exacct::Object
PROTOTYPES: ENABLE

 #
 # Define the stash pointers if required and create and populate @_Constants.
 #
BOOT:
	{
	init_stashes();
	define_constants(PKGBASE "::Object", constants);
	}

 #
 # Return a dual-typed SV containing the type of the object.

Object/Object.xs  view on Meta::CPAN

	SV	*catalog;
	SV	*value;
PREINIT:
	ea_object_t	*ea_obj;
	HV		*stash;
CODE:
	/* Create a new xs_ea_object_t and subsiduary structures. */
	New(0, RETVAL, 1, xs_ea_object_t);
	RETVAL->ea_obj = ea_obj = ea_alloc(sizeof (ea_object_t));
	bzero(ea_obj, sizeof (*ea_obj));
	ea_obj->eo_type = EO_ITEM;
	ea_obj->eo_catalog = catalog_value(catalog);
	INIT_PLAIN_ITEM_FLAGS(RETVAL);
	RETVAL->perl_obj = NULL;

	/* Assign the Item's value. */
	switch (ea_obj->eo_catalog & EXT_TYPE_MASK) {
	case EXT_UINT8:
		ea_obj->eo_item.ei_uint8 = SvIV(value);
		ea_obj->eo_item.ei_size = sizeof (uint8_t);
		break;
	case EXT_UINT16:
		ea_obj->eo_item.ei_uint16 = SvIV(value);
		ea_obj->eo_item.ei_size = sizeof (uint16_t);
		break;
	case EXT_UINT32:
		ea_obj->eo_item.ei_uint32 = SvIV(value);
		ea_obj->eo_item.ei_size = sizeof (uint32_t);
		break;
	case EXT_UINT64:
		ea_obj->eo_item.ei_uint64 = SvIV(value);
		ea_obj->eo_item.ei_size = sizeof (uint64_t);
		break;
	case EXT_DOUBLE:
		ea_obj->eo_item.ei_double = SvNV(value);
		ea_obj->eo_item.ei_size = sizeof (double);
		break;
	case EXT_STRING:
		ea_obj->eo_item.ei_string = ea_strdup(SvPV_nolen(value));
		ea_obj->eo_item.ei_size = SvCUR(value) + 1;
		break;
	case EXT_RAW:
		ea_obj->eo_item.ei_size = SvCUR(value);
		ea_obj->eo_item.ei_raw = ea_alloc(ea_obj->eo_item.ei_size);
		bcopy(SvPV_nolen(value), ea_obj->eo_item.ei_raw,
		    (size_t)ea_obj->eo_item.ei_size);
		break;
	case EXT_EXACCT_OBJECT:
		/*
		 * The ea_obj part is initially empty, and will be populated
		 * from the perl_obj part  when required.
		 */
		stash = SvROK(value) ? SvSTASH(SvRV(value)) : NULL;
		if (stash != Sun_Solaris_Exacct_Object_Item_stash &&
		    stash != Sun_Solaris_Exacct_Object_Group_stash) {
			croak("value is not of type " PKGBASE "::Object");
		}
		RETVAL->perl_obj = copy_xs_ea_object(value);
		ea_obj->eo_item.ei_object = NULL;
		ea_obj->eo_item.ei_size = 0;
		INIT_EMBED_ITEM_FLAGS(RETVAL);
		break;
	/*
	 * EXT_NONE is an invalid type,
	 * EXT_GROUP is created by the Group subclass constructor.
	 */
	case EXT_NONE:
	case EXT_GROUP:
	default:
		ea_free(RETVAL->ea_obj, sizeof (RETVAL->ea_obj));
		Safefree(RETVAL);
		croak("Invalid object type");
		break;
	}
OUTPUT:
	RETVAL

MODULE = Sun::Solaris::Exacct::Object PACKAGE = Sun::Solaris::Exacct::Object::Group
PROTOTYPES: ENABLE

xs_ea_object_t *
new(class, catalog, ...)
	char	*class;
	SV	*catalog;
PREINIT:
	ea_catalog_t	tag;
	ea_object_t	*ea_obj;
	AV		*tied_av, *av;
	SV		*sv, *rv;
	int		i;
CODE:
	tag = catalog_value(catalog);
	if ((tag & EXT_TYPE_MASK) != EXT_GROUP) {
		croak("Invalid object type");
	}

	/* Create a new xs_ea_object_t and subsiduary structures. */
	New(0, RETVAL, 1, xs_ea_object_t);
	RETVAL->ea_obj = ea_obj = ea_alloc(sizeof (ea_object_t));
	bzero(ea_obj, sizeof (*ea_obj));
	ea_obj->eo_type = EO_GROUP;
	ea_obj->eo_catalog = tag;
	INIT_GROUP_FLAGS(RETVAL);
	RETVAL->perl_obj = NULL;

	/* Create a new AV and copy in all the passed Items. */
	av = newAV();
	av_extend(av, items - 2);
	for (i = 2; 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");
		}
		av_store(av, i - 2, copy_xs_ea_object(ST(i)));
	}

	/* Bless the copied AV and tie it to a new AV */
	rv = newRV_noinc((SV *)av);
	sv_bless(rv, Sun_Solaris_Exacct_Object__Array_stash);