Implement libsolv Tcl bindings

Add the necessary build system changes and modifications in the SIWG
interface definition file to enable generation of Tcl bindings. The
build system generates and installs a Tcl module that can used from
tclsh using
  % package require solv
Constants and operations are available in the solv:: namespace, e.g.
  % puts $solv::Solver_POLICY_ILLEGAL_DOWNGRADE
will echo "1".

Rudimentary testing has been done, but this should be considered
experimental for now. We will fix problems as we encounter them.

Signed-off-by: Clemens Lang <neverpanic@gmail.com>

diff --git a/CMakeLists.txt b/CMakeLists.txt
index 45422af4a08033d9c17ae441c9e4e133c4061f8c..c42e1a31cc541081ae55fb760a13719b14070e8c 100644 (file)
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -8,6 +8,7 @@ OPTION (DISABLE_SHARED "Do not build a shared version of the libraries?" OFF)
 OPTION (ENABLE_PERL "Build the perl bindings?" OFF)
 OPTION (ENABLE_PYTHON "Build the python bindings?" OFF)
 OPTION (ENABLE_RUBY "Build the ruby bindings?" OFF)
+OPTION (ENABLE_TCL "Build the Tcl bindings?" OFF)
 
 OPTION (USE_VENDORDIRS "Install the bindings in vendor directories?" OFF)
 
@@ -332,9 +333,9 @@ ENDIF (HAVE_LINKER_AS_NEEDED)
 ADD_SUBDIRECTORY (src)
 ADD_SUBDIRECTORY (ext)
 ADD_SUBDIRECTORY (tools)
-IF (ENABLE_PERL OR ENABLE_PYTHON OR ENABLE_RUBY)
+IF (ENABLE_PERL OR ENABLE_PYTHON OR ENABLE_RUBY OR ENABLE_TCL)
     ADD_SUBDIRECTORY (bindings)
-ENDIF (ENABLE_PERL OR ENABLE_PYTHON OR ENABLE_RUBY)
+ENDIF (ENABLE_PERL OR ENABLE_PYTHON OR ENABLE_RUBY OR ENABLE_TCL)
 ADD_SUBDIRECTORY (examples)
 ADD_SUBDIRECTORY (doc)
 

diff --git a/bindings/CMakeLists.txt b/bindings/CMakeLists.txt
index 90007730f4d6531995eab2abc7ed489b519c8836..34b07846dc45d3cb212ebe49a1d8a4623e22a7a1 100644 (file)
--- a/bindings/CMakeLists.txt
+++ b/bindings/CMakeLists.txt
@@ -14,3 +14,6 @@ ENDIF (ENABLE_PERL)
 IF (ENABLE_RUBY)
     ADD_SUBDIRECTORY (ruby)
 ENDIF (ENABLE_RUBY)
+IF (ENABLE_TCL)
+    ADD_SUBDIRECTORY (tcl)
+ENDIF (ENABLE_TCL)

diff --git a/bindings/solv.i b/bindings/solv.i
index 40307964a605ef75d366450e7406347334596374..601a3204e405c8422df73ef094a62f172b9a3f29 100644 (file)
--- a/bindings/solv.i
+++ b/bindings/solv.i
@@ -49,6 +49,8 @@ typedef struct {
 %typemap(out,noblock=1,fragment="SWIG_FromCharPtrAndSize") BinaryBlob {
 #if defined(SWIGPYTHON) && defined(PYTHON3)
   $result = $1.data ? Py_BuildValue("y#", $1.data, $1.len) : SWIG_Py_Void();
+#elif defined(SWIGTCL)
+  Tcl_SetObjResult(interp, SWIG_FromCharPtrAndSize($1.data, $1.len));
 #else
   $result = SWIG_FromCharPtrAndSize($1.data, $1.len);
 #if defined(SWIGPERL)
@@ -228,7 +230,80 @@ typedef struct {
 %enddef
 #endif
 
+#if defined(SWIGTCL)
+%typemap(in) Queue {
+  /* Check if is a list */
+  int retval = TCL_OK;
+  int size = 0;
+  int i = 0;
+
+  if (TCL_OK != (retval = Tcl_ListObjLength(interp, $input, &size))) {
+    Tcl_SetObjResult(interp, Tcl_NewStringObj("argument is not a list", -1));
+    return retval;
+  }
+
+  queue_init(&$1);
+
+  for (i = 0; i < size; i++) {
+    Tcl_Obj *o = NULL;
+    int v;
+
+    if (TCL_OK != (retval = Tcl_ListObjIndex(interp, $input, i, &o))) {
+      queue_free(&$1);
+      Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to retrieve a list member", -1));
+      return retval;
+    }
+
+    int e = SWIG_AsVal_int SWIG_TCL_CALL_ARGS_2(o, &v);
+    if (!SWIG_IsOK(e)) {
+      queue_free(&$1);
+      SWIG_exception_fail(SWIG_ArgError(e), "list must contain only integers");
+      return TCL_ERROR;
+    }
+
+    queue_push(&$1, v);
+  }
+}
+
+%typemap(out) Queue {
+  Tcl_Obj *objvx[$1.count];
+  int i;
+
+  for (i = 0; i < $1.count; i++) {
+    objvx[i] = SWIG_From_int($1.elements[i]);
+  }
+
+  Tcl_SetObjResult(interp, Tcl_NewListObj($1.count, objvx));
+
+  queue_free(&$1);
+}
+
+%define Queue2Array(type, step, con) %{
+  { /* scope is needed to make the goto of SWIG_exception_fail work */
+    int i;
+    int cnt = $1.count / step;
+    Id *idp = $1.elements;
+    Tcl_Obj *objvx[cnt];
+
+    for (i = 0; i < cnt; i++, idp += step) {
+      Id id = *idp;
+#define result resultx
+#define Tcl_SetObjResult(i, x) resultobj = x
+      type result = con;
+      Tcl_Obj *resultobj;
+      $typemap(out, type)
+      objvx[i] = resultobj;
+#undef Tcl_SetObjResult
+#undef result
+    }
+    queue_free(&$1);
+    Tcl_SetObjResult(interp, Tcl_NewListObj(cnt, objvx));
+  }
+%}
 
+%enddef
+
+#endif
 
 
 #if defined(SWIGPERL)
@@ -357,6 +432,11 @@ typedef VALUE AppObjectPtr;
 %typemap(out) AppObjectPtr {
   $result = (VALUE)$1;
 }
+#elif defined(SWIGTCL)
+typedef TclObj *AppObjectPtr;
+%typemap(out) AppObjectPtr {
+  Tcl_SetObjResult(interp, $1 ? $1 : Tcl_NewObj());
+}
 #endif
 
 
@@ -372,6 +452,8 @@ typedef VALUE AppObjectPtr;
 SWIGINTERN int
 #ifdef SWIGRUBY
 SWIG_AsValSolvFpPtr(VALUE obj, FILE **val) {
+#elif defined(SWIGTCL)
+SWIG_AsValSolvFpPtr SWIG_TCL_DECL_ARGS_2(void *obj, FILE **val) {
 #else
 SWIG_AsValSolvFpPtr(void *obj, FILE **val) {
 #endif
@@ -393,6 +475,10 @@ SWIG_AsValSolvFpPtr(void *obj, FILE **val) {
   return SWIG_TypeError;
 }
 
+#if defined(SWIGTCL)
+#define SWIG_AsValSolvFpPtr(x, y) SWIG_AsValSolvFpPtr SWIG_TCL_CALL_ARGS_2(x, y)
+#endif
+
 }
 
 
@@ -401,6 +487,8 @@ SWIG_AsValSolvFpPtr(void *obj, FILE **val) {
 SWIGINTERN int
 #ifdef SWIGRUBY
 SWIG_AsValDepId(VALUE obj, int *val) {
+#elif defined(SWIGTCL)
+SWIG_AsValDepId SWIG_TCL_DECL_ARGS_2(void *obj, int *val) {
 #else
 SWIG_AsValDepId(void *obj, int *val) {
 #endif
@@ -408,7 +496,11 @@ SWIG_AsValDepId(void *obj, int *val) {
   void *vptr = 0;
   int ecode;
   if (!desc) desc = SWIG_TypeQuery("Dep *");
+#ifdef SWIGTCL
+  ecode = SWIG_AsVal_int SWIG_TCL_CALL_ARGS_2(obj, val);
+#else
   ecode = SWIG_AsVal_int(obj, val);
+#endif
   if (SWIG_IsOK(ecode))
     return ecode;
   if ((SWIG_ConvertPtr(obj, &vptr, desc, 0)) == SWIG_OK) {
@@ -419,6 +511,9 @@ SWIG_AsValDepId(void *obj, int *val) {
   return SWIG_TypeError;
 }
 
+#ifdef SWIGTCL
+#define SWIG_AsValDepId(x, y) SWIG_AsValDepId SWIG_TCL_CALL_ARGS_2(x, y)
+#endif
 }
 
 %typemap(out) disown_helper {
@@ -431,7 +526,15 @@ SWIG_AsValDepId(void *obj, int *val) {
 #ifdef SWIGPERL
   SWIG_ConvertPtr(ST(0), &argp1,SWIGTYPE_p_Pool, SWIG_POINTER_DISOWN |  0 );
 #endif
+#ifdef SWIGTCL
+  SWIG_ConvertPtr(objv[1], &argp1, SWIGTYPE_p_Pool, SWIG_POINTER_DISOWN | 0);
+#endif
+
+#ifdef SWIGTCL
+  Tcl_SetObjResult(interp, SWIG_From_int((int)(0)));
+#else
   $result = SWIG_From_int((int)(0));
+#endif
 }
 
 %include "typemaps.i"
@@ -1238,8 +1341,59 @@ typedef struct {
   void set_loadcallback(VALUE callable) {
     pool_setloadcallback($self, callable ? loadcallback : 0, (void *)callable);
   }
+#elif defined(SWIGTCL)
+  %{
+  typedef struct {
+    Tcl_Interp *interp;
+    Tcl_Obj *obj;
+  } tcl_callback_t;
+  SWIGINTERN int loadcallback(Pool *pool, Repodata *data, void *d) {
+    tcl_callback_t *callback_var = (tcl_callback_t *)d;
+    XRepodata *xd = new_XRepodata(data->repo, data->repodataid);
+    Tcl_Obj *objvx[2];
+    objvx[0] = callback_var->obj;
+    objvx[1] = SWIG_NewPointerObj(SWIG_as_voidptr(xd), SWIGTYPE_p_XRepodata, SWIG_POINTER_OWN | 0); 
+    int result = Tcl_EvalObjv(callback_var->interp, sizeof(objvx), objvx, TCL_EVAL_GLOBAL);
+    int ecode = 0;
+    int vresult = 0;
+    Tcl_DecrRefCount(objvx[1]);
+    if (result != TCL_OK)
+      return 0; /* exception */
+    ecode = SWIG_AsVal_int(callback_var->interp, Tcl_GetObjResult(callback_var->interp), &vresult);
+    return SWIG_IsOK(ecode) ? vresult : 0;
+  }
+  %}
+  void set_loadcallback(Tcl_Obj *callable, Tcl_Interp *interp) {
+    tcl_callback_t *callable_temp;
+    if ($self->loadcallback == loadcallback) {
+      tcl_callback_t *obj = $self->loadcallbackdata;
+      Tcl_DecrRefCount(obj->obj);
+      free(obj);
+    }
+    if (callable) {
+      Tcl_IncrRefCount(callable);
+      callable_temp = malloc(sizeof(tcl_callback_t));
+      callable_temp->interp = interp;
+      callable_temp->obj = callable;
+    }
+    else {
+      callable_temp = NULL;
+    }
+    pool_setloadcallback($self, callable ? loadcallback : 0, callable_temp);
+  }
 #endif
 
+#if defined(SWIGTCL)
+  ~Pool() {
+    Pool_set_loadcallback($self, 0, 0);
+    pool_free($self);
+  }
+  disown_helper free() {
+    Pool_set_loadcallback($self, 0, 0);
+    pool_free($self);
+    return 0;
+  }
+#else
   ~Pool() {
     Pool_set_loadcallback($self, 0);
     pool_free($self);
@@ -1249,6 +1403,7 @@ typedef struct {
     pool_free($self);
     return 0;
   }
+#endif
   disown_helper disown() {
     return 0;
   }

diff --git a/bindings/tcl/CMakeLists.txt b/bindings/tcl/CMakeLists.txt
new file mode 100644 (file)
index 0000000..f78de9f
--- /dev/null
+++ b/bindings/tcl/CMakeLists.txt
@@ -0,0 +1,38 @@
+FIND_PACKAGE (TCL)
+
+SET (SWIG_TCL_FLAGS -namespace -pkgversion ${VERSION})
+
+EXECUTE_PROCESS (
+    COMMAND echo "puts -nonewline [lindex [::tcl::tm::list] end]"
+    COMMAND ${TCL_TCLSH}
+    OUTPUT_VARIABLE TCL_INSTALL_DIR
+)
+
+MESSAGE (STATUS "Tclsh executable: ${TCL_TCLSH}")
+MESSAGE (STATUS "Tcl installation dir: ${TCL_INSTALL_DIR}")
+
+ADD_CUSTOM_COMMAND (
+    OUTPUT solv_tcl.c
+    COMMAND ${SWIG_EXECUTABLE} ${SWIG_FLAGS} -tcl ${SWIG_TCL_FLAGS} -I${CMAKE_SOURCE_DIR}/src -o solv_tcl.c ${CMAKE_SOURCE_DIR}/bindings/solv.i
+    WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}
+    DEPENDS ${CMAKE_SOURCE_DIR}/bindings/solv.i
+)
+
+ADD_DEFINITIONS(-Wno-unused)
+INCLUDE_DIRECTORIES (${TCL_INCLUDE_PATH})
+
+ADD_LIBRARY (bindings_tcl SHARED solv_tcl.c)
+SET_TARGET_PROPERTIES (bindings_tcl PROPERTIES PREFIX "" OUTPUT_NAME "solv-${VERSION}" INSTALL_NAME_DIR "${TCL_INSTALL_DIR}")
+TARGET_LINK_LIBRARIES (bindings_tcl libsolvext libsolv ${TCL_LIBRARY} ${SYSTEM_LIBRARIES})
+INSTALL (TARGETS bindings_tcl LIBRARY DESTINATION ${TCL_INSTALL_DIR})
+
+ADD_CUSTOM_COMMAND (
+    OUTPUT solv.tm
+       COMMAND sed -e "s/__VERSION__/${VERSION}/" ${CMAKE_SOURCE_DIR}/bindings/tcl/solv.tm.in >${CMAKE_CURRENT_BINARY_DIR}/solv.tm
+    DEPENDS ${CMAKE_SOURCE_DIR}/bindings/tcl/solv.tm.in
+    COMMENT "Creating Tcl module to load libsolv"
+)
+ADD_CUSTOM_TARGET (solv_tm ALL DEPENDS solv.tm)
+SET_SOURCE_FILES_PROPERTIES (solv.tm PROPERTIES GENERATED TRUE)
+
+INSTALL (FILES ${CMAKE_CURRENT_BINARY_DIR}/solv.tm DESTINATION ${TCL_INSTALL_DIR} RENAME solv-${VERSION}.tm)

diff --git a/bindings/tcl/solv.tm.in b/bindings/tcl/solv.tm.in
new file mode 100644 (file)
index 0000000..3b94771
--- /dev/null
+++ b/bindings/tcl/solv.tm.in
@@ -0,0 +1,4 @@
+package require Tcl
+
+#package provide solv __VERSION__
+load [::file join [::file dirname [::info script]] "solv-__VERSION__[::info sharedlibextension]"]