You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@lucy.apache.org by ma...@apache.org on 2009/09/07 00:25:17 UTC
svn commit: r811925 - in /lucene/lucy/trunk/perl/xs: ./ XSBind.c XSBind.h
Author: marvin
Date: Sun Sep 6 22:25:17 2009
New Revision: 811925
URL: http://svn.apache.org/viewvc?rev=811925&view=rev
Log:
Commit the remainder of LUCY-27, adding XSBind.h and XSBind.c -- which contain
routines for converting back and forth between Perl and Lucy.
Added:
lucene/lucy/trunk/perl/xs/
lucene/lucy/trunk/perl/xs/XSBind.c (with props)
lucene/lucy/trunk/perl/xs/XSBind.h (with props)
Added: lucene/lucy/trunk/perl/xs/XSBind.c
URL: http://svn.apache.org/viewvc/lucene/lucy/trunk/perl/xs/XSBind.c?rev=811925&view=auto
==============================================================================
--- lucene/lucy/trunk/perl/xs/XSBind.c (added)
+++ lucene/lucy/trunk/perl/xs/XSBind.c Sun Sep 6 22:25:17 2009
@@ -0,0 +1,364 @@
+#define C_LUCY_OBJ
+#define C_LUCY_ZOMBIECHARBUF
+#include "XSBind.h"
+#include "Lucy/Util/StringHelper.h"
+
+/* Convert a Perl hash into a KS Hash. Caller takes responsibility for a
+ * refcount.
+ */
+static lucy_Hash*
+S_perl_hash_to_lucy_hash(HV *phash);
+
+/* Convert a Perl array into a KS VArray. Caller takes responsibility for a
+ * refcount.
+ */
+static lucy_VArray*
+S_perl_array_to_lucy_array(AV *parray);
+
+/* Convert a VArray to a Perl array. Caller takes responsibility for a
+ * refcount.
+ */
+static SV*
+S_lucy_array_to_perl_array(lucy_VArray *varray);
+
+/* Convert a Hash to a Perl hash. Caller takes responsibility for a
+ * refcount.
+ */
+static SV*
+S_lucy_hash_to_perl_hash(lucy_Hash *hash);
+
+lucy_Obj*
+XSBind_new_blank_obj(SV *either_sv)
+{
+ lucy_VTable *vtable;
+
+ /* Get a VTable. */
+ if ( sv_isobject(either_sv)
+ && sv_derived_from(either_sv, "Lucy::Obj")
+ ) {
+ /* Use the supplied object's VTable. */
+ IV iv_ptr = SvIV(SvRV(either_sv));
+ lucy_Obj *self = INT2PTR(lucy_Obj*, iv_ptr);
+ vtable = self->vtable;
+ }
+ else {
+ /* Use the supplied class name string to find a VTable. */
+ STRLEN len;
+ char *ptr = SvPVutf8(either_sv, len);
+ lucy_ZombieCharBuf klass = lucy_ZCB_make_str(ptr, len);
+ vtable = lucy_VTable_singleton((lucy_CharBuf*)&klass, NULL);
+ }
+
+ /* Use the VTable to allocate a new blank object of the right size. */
+ return Lucy_VTable_Make_Obj(vtable);
+}
+
+lucy_Obj*
+XSBind_sv_to_lucy_obj(SV *sv, lucy_VTable *vtable, lucy_ZombieCharBuf *zcb)
+{
+ lucy_Obj *retval = XSBind_maybe_sv_to_lucy_obj(sv, vtable, zcb);
+ if (!retval) {
+ THROW(LUCY_ERR, "Not a %o", Lucy_VTable_Get_Name(vtable));
+ }
+ return retval;
+}
+
+lucy_Obj*
+XSBind_maybe_sv_to_lucy_obj(SV *sv, lucy_VTable *vtable,
+ lucy_ZombieCharBuf *zcb)
+{
+ lucy_Obj *retval = NULL;
+ if (XSBind_sv_defined(sv)) {
+ if ( sv_isobject(sv)
+ && sv_derived_from(sv,
+ (char*)Lucy_CB_Get_Ptr8(Lucy_VTable_Get_Name(vtable)))
+ ) {
+ /* Unwrap a real Lucy object. */
+ IV tmp = SvIV( SvRV(sv) );
+ retval = INT2PTR(lucy_Obj*, tmp);
+ }
+ else if ( zcb &&
+ ( vtable == LUCY_ZOMBIECHARBUF
+ || vtable == LUCY_VIEWCHARBUF
+ || vtable == LUCY_CHARBUF
+ || vtable == LUCY_OBJ)
+ ) {
+ /* Wrap the string from an ordinary Perl scalar inside a
+ * ZombieCharBuf. */
+ STRLEN size;
+ char *ptr = SvPVutf8(sv, size);
+ Lucy_ViewCB_Assign_Str(zcb, ptr, size);
+ retval = (lucy_Obj*)zcb;
+ }
+ else if (SvROK(sv)) {
+ /* Attempt to convert Perl hashes and arrays into their Lucy
+ * analogues. */
+ SV *inner = SvRV(sv);
+ if (SvTYPE(inner) == SVt_PVAV && vtable == LUCY_VARRAY) {
+ retval = (lucy_Obj*)S_perl_array_to_lucy_array((AV*)inner);
+ }
+ else if (SvTYPE(inner) == SVt_PVHV && vtable == LUCY_HASH) {
+ retval = (lucy_Obj*)S_perl_hash_to_lucy_hash((HV*)inner);
+ }
+
+ if(retval) {
+ /* Mortalize the converted object -- which is somewhat
+ * dangerous, but is the only way to avoid requiring that the
+ * caller take responsibility for a refcount. */
+ SV *mortal = Lucy_Obj_To_Host(retval);
+ LUCY_DECREF(retval);
+ sv_2mortal(mortal);
+ }
+ }
+ }
+
+ return retval;
+}
+
+SV*
+XSBind_lucy_to_perl(lucy_Obj *obj)
+{
+ if (obj == NULL) {
+ return newSV(0);
+ }
+ else if (LUCY_OBJ_IS_A(obj, LUCY_CHARBUF)) {
+ return XSBind_cb_to_sv((lucy_CharBuf*)obj);
+ }
+ else if (LUCY_OBJ_IS_A(obj, LUCY_VARRAY)) {
+ return S_lucy_array_to_perl_array((lucy_VArray*)obj);
+ }
+ else if (LUCY_OBJ_IS_A(obj, LUCY_HASH)) {
+ return S_lucy_hash_to_perl_hash((lucy_Hash*)obj);
+ }
+ else {
+ return (SV*)Lucy_Obj_To_Host(obj);
+ }
+}
+
+lucy_Obj*
+XSBind_perl_to_lucy(SV *sv)
+{
+ lucy_Obj *retval = NULL;
+
+ if (XSBind_sv_defined(sv)) {
+ if (SvROK(sv)) {
+ /* Deep conversion of references. */
+ SV *inner = SvRV(sv);
+ if (SvTYPE(inner) == SVt_PVAV) {
+ retval = (lucy_Obj*)S_perl_array_to_lucy_array((AV*)inner);
+ }
+ else if (SvTYPE(inner) == SVt_PVHV) {
+ retval = (lucy_Obj*)S_perl_hash_to_lucy_hash((HV*)inner);
+ }
+ else if ( sv_isobject(sv)
+ && sv_derived_from(sv, "Lucy::Obj")
+ ) {
+ IV tmp = SvIV(inner);
+ retval = INT2PTR(lucy_Obj*, tmp);
+ (void)LUCY_INCREF(retval);
+ }
+ }
+
+ /* It's either a plain scalar or a non-Lucy Perl object, so
+ * stringify. */
+ if (!retval) {
+ STRLEN len;
+ char *ptr = SvPVutf8(sv, len);
+ retval = (lucy_Obj*)lucy_CB_new_from_trusted_utf8(ptr, len);
+ }
+ }
+ else if (sv) {
+ /* Deep conversion of raw AVs and HVs. */
+ if (SvTYPE(sv) == SVt_PVAV) {
+ retval = (lucy_Obj*)S_perl_array_to_lucy_array((AV*)sv);
+ }
+ else if (SvTYPE(sv) == SVt_PVHV) {
+ retval = (lucy_Obj*)S_perl_hash_to_lucy_hash((HV*)sv);
+ }
+ }
+
+ return retval;
+}
+
+SV*
+XSBind_cb_to_sv(const lucy_CharBuf *cb)
+{
+ if (!cb) {
+ return newSV(0);
+ }
+ else {
+ SV *sv = newSVpvn((char*)Lucy_CB_Get_Ptr8(cb), Lucy_CB_Get_Size(cb));
+ SvUTF8_on(sv);
+ return sv;
+ }
+}
+
+static lucy_Hash*
+S_perl_hash_to_lucy_hash(HV *phash)
+{
+ chy_u32_t num_keys = hv_iterinit(phash);
+ lucy_Hash *retval = lucy_Hash_new(num_keys);
+
+ while (num_keys--) {
+ HE *entry = hv_iternext(phash);
+ STRLEN key_len;
+ /* Copied from Perl 5.10.0 HePV macro, because the HePV macro in
+ * earlier versions of Perl triggers a compiler warning. */
+ char *key = HeKLEN(entry) == HEf_SVKEY
+ ? SvPV(HeKEY_sv(entry), key_len)
+ : ((key_len = HeKLEN(entry)), HeKEY(entry));
+ SV *value_sv = HeVAL(entry);
+ if (!lucy_StrHelp_utf8_valid(key, key_len)) {
+ /* Force key to UTF-8. This is kind of a buggy area for Perl, and
+ * may result in round-trip weirdness. */
+ SV *key_sv = HeSVKEY_force(entry);
+ key = SvPVutf8(key_sv, key_len);
+ }
+
+ /* Recurse for each value. */
+ Lucy_Hash_Store_Str(retval, key, key_len,
+ XSBind_perl_to_lucy(value_sv));
+ }
+
+ return retval;
+}
+
+static lucy_VArray*
+S_perl_array_to_lucy_array(AV *parray)
+{
+ const chy_u32_t size = av_len(parray) + 1;
+ lucy_VArray *retval = lucy_VA_new(size);
+ chy_u32_t i;
+
+ /* Iterate over array elems. */
+ for (i = 0; i < size; i++) {
+ SV **elem_sv = av_fetch(parray, i, false);
+ if (elem_sv) {
+ lucy_Obj *elem = XSBind_perl_to_lucy(*elem_sv);
+ if (elem) { Lucy_VA_Store(retval, i, elem); }
+ }
+ }
+ Lucy_VA_Resize(retval, size); /* needed if last elem is NULL */
+
+ return retval;
+}
+
+static SV*
+S_lucy_array_to_perl_array(lucy_VArray *varray)
+{
+ AV *perl_array = newAV();
+ chy_u32_t num_elems = Lucy_VA_Get_Size(varray);
+
+ /* Iterate over array elems. */
+ if (num_elems) {
+ chy_u32_t i;
+ av_fill(perl_array, num_elems - 1);
+ for (i = 0; i < num_elems; i++) {
+ lucy_Obj *val = Lucy_VA_Fetch(varray, i);
+ if (val == NULL) {
+ continue;
+ }
+ else {
+ /* Recurse for each value. */
+ SV *const val_sv = XSBind_lucy_to_perl(val);
+ av_store(perl_array, i, val_sv);
+ }
+ }
+ }
+
+ return newRV_noinc((SV*)perl_array);
+}
+
+static SV*
+S_lucy_hash_to_perl_hash(lucy_Hash *hash)
+{
+ HV *perl_hash = newHV();
+ lucy_CharBuf *key;
+ lucy_Obj *val;
+
+ /* Iterate over key-value pairs. */
+ Lucy_Hash_Iter_Init(hash);
+ while (Lucy_Hash_Iter_Next(hash, (lucy_Obj**)&key, &val)) {
+ /* Recurse for each value. */
+ SV *val_sv = XSBind_lucy_to_perl(val);
+ if (!LUCY_OBJ_IS_A(key, LUCY_CHARBUF)) {
+ LUCY_THROW(LUCY_ERR,
+ "Can't convert a key of class %o to a Perl hash key",
+ Lucy_Obj_Get_Class_Name(key));
+ }
+ hv_store(perl_hash, (char*)Lucy_CB_Get_Ptr8(key),
+ Lucy_CB_Get_Size(key), val_sv, 0);
+ }
+
+ return newRV_noinc((SV*)perl_hash);
+}
+
+void
+XSBind_allot_params(SV** stack, chy_i32_t start, chy_i32_t num_stack_elems,
+ char* params_hash_name, ...)
+{
+ va_list args;
+ HV *params_hash = get_hv(params_hash_name, 0);
+ SV **target;
+ chy_i32_t i;
+ chy_i32_t args_left = (num_stack_elems - start) / 2;
+
+ /* Retrieve the params hash, which must be a package global. */
+ if (params_hash == NULL) {
+ THROW(LUCY_ERR, "Can't find hash named %s", params_hash_name);
+ }
+
+ /* Verify that our args come in pairs. Bail if there are no args. */
+ if (num_stack_elems == start) { return; }
+ if ((num_stack_elems - start) % 2 != 0) {
+ THROW(LUCY_ERR, "Expecting hash-style params, got odd number of args");
+ }
+
+ /* Validate param names. */
+ for (i = start; i < num_stack_elems; i += 2) {
+ SV *const key_sv = stack[i];
+ STRLEN key_len;
+ const char *key = SvPV(key_sv, key_len); /* assume ASCII labels */
+ if (!hv_exists(params_hash, key, key_len)) {
+ THROW(LUCY_ERR, "Invalid parameter: '%s'", key);
+ }
+ }
+
+ va_start(args, params_hash_name);
+ while (args_left && NULL != (target = va_arg(args, SV**))) {
+ char *label = va_arg(args, char*);
+ int label_len = va_arg(args, int);
+
+ /* Iterate through stack looking for a label match. Work backwards so
+ * that if the label is doubled up we get the last one. */
+ for (i = num_stack_elems; i >= start + 2; i -= 2) {
+ chy_i32_t tick = i - 2;
+ SV *const key_sv = stack[tick];
+ const chy_i32_t comparison = lucy_StrHelp_compare_strings(
+ label, SvPVX(key_sv), label_len, SvCUR(key_sv));
+ if (comparison == 0) {
+ *target = stack[tick + 1];
+ args_left--;
+ break;
+ }
+ }
+ }
+ va_end(args);
+}
+
+/**
+ * Copyright 2009 The Apache Software Foundation
+ *
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
Propchange: lucene/lucy/trunk/perl/xs/XSBind.c
------------------------------------------------------------------------------
svn:eol-style = native
Added: lucene/lucy/trunk/perl/xs/XSBind.h
URL: http://svn.apache.org/viewvc/lucene/lucy/trunk/perl/xs/XSBind.h?rev=811925&view=auto
==============================================================================
--- lucene/lucy/trunk/perl/xs/XSBind.h (added)
+++ lucene/lucy/trunk/perl/xs/XSBind.h Sun Sep 6 22:25:17 2009
@@ -0,0 +1,183 @@
+/* XSBind.h -- Functions to help bind Lucy to Perl XS api.
+ */
+
+#ifndef H_LUCY_XSBIND
+#define H_LUCY_XSBIND 1
+
+#include "charmony.h"
+#include "Lucy/Obj.h"
+#include "Lucy/Obj/CharBuf.h"
+#include "Lucy/Obj/Err.h"
+#include "Lucy/Obj/Hash.h"
+#include "Lucy/Obj/VArray.h"
+#include "Lucy/Obj/VTable.h"
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define NEED_newRV_noinc_GLOBAL
+#include "ppport.h"
+
+/** Given either a class name or a perl object, manufacture a new KS
+ * object suitable for supplying to a lucy_Foo_init() function.
+ */
+lucy_Obj*
+lucy_XSBind_new_blank_obj(SV *either_sv);
+
+/** Test whether an SV is defined. Handles "get" magic, unlike SvOK on its
+ * own.
+ */
+static CHY_INLINE chy_bool_t
+lucy_XSBind_sv_defined(SV *sv)
+{
+ if (!sv || !SvANY(sv)) { return false; }
+ if (SvGMAGICAL(sv)) { mg_get(sv); }
+ return SvOK(sv);
+}
+
+/** If the SV contains a KS object which passes an "isa" test against the
+ * passed-in VTable, return a pointer to it. If not, but <code>zcb</code> is
+ * supplied and a ZombieCharBuf would satisfy the "isa" test, stringify the
+ * SV, assign its string to <code>zcb</code> and return <code>zcb</code>
+ * instead. If all else fails, throw an exception.
+ */
+lucy_Obj*
+lucy_XSBind_sv_to_lucy_obj(SV *sv, lucy_VTable *vtable,
+ lucy_ZombieCharBuf *zcb);
+
+/** As XSBind_sv_to_lucy_obj above, but returns NULL instead of throwing an
+ * exception.
+ */
+lucy_Obj*
+lucy_XSBind_maybe_sv_to_lucy_obj(SV *sv, lucy_VTable *vtable,
+ lucy_ZombieCharBuf *zcb);
+
+/** Derive an SV from a Lucy object. If the KS object is NULL, the SV
+ * will be undef.
+ *
+ * The new SV has single refcount for which the caller must take
+ * responsibility.
+ */
+static CHY_INLINE SV*
+lucy_XSBind_lucy_obj_to_sv(lucy_Obj *obj)
+{
+ return obj ? Lucy_Obj_To_Host(obj) : newSV(0);
+}
+
+/** XSBind_lucy_obj_to_sv, with a cast.
+ */
+#define LUCY_OBJ_TO_SV(_obj) lucy_XSBind_lucy_obj_to_sv((lucy_Obj*)_obj)
+
+/** As XSBind_lucy_obj_to_sv above, except decrements the object's refcount
+ * after creating the SV. This is useful when the KS expression creates a new
+ * refcount, e.g. a call to a constructor.
+ */
+static CHY_INLINE SV*
+lucy_XSBind_lucy_obj_to_sv_noinc(lucy_Obj *obj)
+{
+ SV *retval;
+ if (obj) {
+ retval = Lucy_Obj_To_Host(obj);
+ Lucy_Obj_Dec_RefCount(obj);
+ }
+ else {
+ retval = newSV(0);
+ }
+ return retval;
+}
+
+/** XSBind_lucy_obj_to_sv_noinc, with a cast.
+ */
+#define LUCY_OBJ_TO_SV_NOINC(_obj) \
+ lucy_XSBind_lucy_obj_to_sv_noinc((lucy_Obj*)_obj)
+
+/** Deep conversion of KS objects to Perl objects -- CharBufs to UTF-8 SVs,
+ * ByteBufs to SVs, VArrays to Perl array refs, Hashes to Perl hashrefs, and
+ * any other object to a Perl object wrapping the KS Obj.
+ */
+SV*
+lucy_XSBind_lucy_to_perl(lucy_Obj *obj);
+
+/** Deep conversion of Perl data structures to KS objects -- Perl hash to
+ * Hash*, Perl array to VArray*, Lucy objects stripped of their
+ * wrappers, and everything else stringified and turned to a CharBuf.
+ */
+lucy_Obj*
+lucy_XSBind_perl_to_lucy(SV *sv);
+
+/** Convert a CharBuf into a new UTF-8 string SV.
+ */
+SV*
+lucy_XSBind_cb_to_sv(const lucy_CharBuf *cb);
+
+/** Process hash-style params passed to an XS subroutine. The varargs must
+ * come batched in groups of three: an SV**, the name of the parameter, and
+ * length of the paramter name. A NULL pointer terminates the list:
+ *
+ * lucy_XSBind_allot_params(stack, start, num_stack_elems,
+ * "Lucy::Search::TermQuery::new_PARAMS",
+ * &field_sv, "field", 5,
+ * &term_sv, "term", 4,
+ * NULL);
+ *
+ * All labeled params found on the stack will be assigned to the appropriate
+ * SV**.
+ *
+ * @param stack The Perl stack.
+ * @param start Where on the Perl stack to start looking for params. For
+ * methods, this would typically be 1; for functions, most likely 0.
+ * @param num_stack_elems The number of arguments passed to the Perl function
+ * (generally, the XS variable "items").
+ * @param params_hash_name The name of a package global hash. Any param
+ * labels which are not present in this hash will trigger an exception.
+ */
+void
+lucy_XSBind_allot_params(SV** stack, chy_i32_t start,
+ chy_i32_t num_stack_elems,
+ char* params_hash_name, ...);
+
+/* Define short names for all the functions in this file. Note that these
+ * short names are ALWAYS in effect, since they are only used for Perl and we
+ * can be confident they don't conflict with anything. (It's prudent to use
+ * full symbols nevertheless in case someone else defines e.g. a function
+ * named "XSBind_sv_defined".)
+ */
+#define XSBind_new_blank_obj lucy_XSBind_new_blank_obj
+#define XSBind_sv_defined lucy_XSBind_sv_defined
+#define XSBind_sv_to_lucy_obj lucy_XSBind_sv_to_lucy_obj
+#define XSBind_maybe_sv_to_lucy_obj lucy_XSBind_maybe_sv_to_lucy_obj
+#define XSBind_lucy_obj_to_sv lucy_XSBind_lucy_obj_to_sv
+#define XSBind_lucy_obj_to_sv_noinc lucy_XSBind_lucy_obj_to_sv_noinc
+#define XSBind_lucy_to_perl lucy_XSBind_lucy_to_perl
+#define XSBind_perl_to_lucy lucy_XSBind_perl_to_lucy
+#define XSBind_cb_to_sv lucy_XSBind_cb_to_sv
+#define XSBind_enable_overload lucy_XSBind_enable_overload
+#define XSBind_allot_params lucy_XSBind_allot_params
+
+/* Strip the prefix from some common lucy_ symbols where we know there's no
+ * conflict with Perl. It's a little inconsistent to do this rather than
+ * leave all symbols at full size, but the succinctness is worth it.
+ */
+#define THROW LUCY_THROW
+#define WARN LUCY_WARN
+#define OVERRIDDEN LUCY_OVERRIDDEN
+
+#endif /* H_LUCY_XSBIND */
+
+/**
+ * Copyright 2009 The Apache Software Foundation
+ *
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
Propchange: lucene/lucy/trunk/perl/xs/XSBind.h
------------------------------------------------------------------------------
svn:eol-style = native