Make unload support configurable, and properly orphan json objtype in…

…stances when unloaded

.gitmodules

@@ -1,3 +1,8 @@
 [submodule "tclconfig"]
  path = tclconfig
  url = https://github.com/tcltk/tclconfig
+ shallow = true
+[submodule "tests/JSONTestSuite"]
+ path = tests/JSONTestSuite
+ url = https://github.com/nst/JSONTestSuite
+ shallow = true

Makefile.in

@@ -155,7 +155,7 @@ INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@
 PKG_CFLAGS = @PKG_CFLAGS@
 
 # TCL_DEFS is not strictly need here, but if you remove it, then you
-# must make sure that configure.in checks for the necessary components
+# must make sure that configure.ac checks for the necessary components
 # that your library may use. TCL_DEFS can actually be a problem if
 # you do not compile with a similar machine setup as the Tcl core was
 # compiled with.
@@ -173,9 +173,10 @@ CFLAGS = @CFLAGS@
 COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
 
 VALGRIND = valgrind
+VALGRINDEXTRA =
 VALGRINDARGS = --tool=memcheck --num-callers=8 --leak-resolution=high \
  --leak-check=yes -v --suppressions=suppressions --keep-debuginfo=yes \
- --trace-children=yes
+ --trace-children=yes $(VALGRINDEXTRA)
 PGOGEN_BUILD = -fprofile-generate=prof
 PGO_BUILD = @PGO_BUILD@
 PGO=
@@ -264,7 +265,7 @@ tests/JSONTestSuite/test_parsing: binaries libraries
  [list load `@CYGPATH@ $(PKG_LIB_FILE)` $(PACKAGE_NAME)]"
 
 benchmark: binaries libraries
- $(TCLSH) `@CYGPATH@ $(srcdir)/bench/run.tcl` $(TESTFLAGS)
+ $(TCLSH) `@CYGPATH@ $(srcdir)/bench/run.tcl` $(TESTFLAGS) -load package\ ifneeded\ $(PACKAGE_NAME)\ $(PACKAGE_VERSION)\ [list\ load\ `@CYGPATH@ $(PKG_LIB_FILE)`\ [string\ totitle\ $(PACKAGE_NAME)]]
 
 shell: binaries libraries
  @$(TCLSH) $(SCRIPT)
@@ -388,7 +389,7 @@ genstubs:
 
 #========================================================================
 # Don't modify the file to clean here. Instead, set the "CLEANFILES"
-# variable in configure.in
+# variable in configure.ac
 #========================================================================
 
 clean:
@@ -492,7 +493,7 @@ coverage:
  make -C . PGO="--coverage" clean binaries libraries test
 
 .PHONY: all binaries clean depend distclean doc install libraries test
-.PHONY: valgrind valgrind-shell vim-gdb vim-core pgo coverage benchmark
+.PHONY: shell gdb valgrind valgrindshell vim-gdb vim-core pgo coverage benchmark
 
 # Tell versions [3.59,3.63) of GNU make to not export all variables.
 # Otherwise a system limit (for SysV at least) may be exceeded.

aclocal.m4

@@ -51,17 +51,42 @@ AC_DEFUN([ENABLE_DEDUP], [
  #trap '' DEBUG
 ])
 
-AC_DEFUN([CHECK_DEBUG], [
- AC_MSG_CHECKING([whether to build in debug mode])
+AC_DEFUN([ENABLE_DEBUG], [
+ #trap 'echo "val: (${enable_debug+set}), debug_ok: ($debug_ok), DEBUG: ($DEBUG)"' DEBUG
+ AC_MSG_CHECKING([whether to support debuging])
  AC_ARG_ENABLE(debug,
- [ --enable-debug Build in debug mode (default: off)],
- [enable_debug=$enableval],
- [enable_debug="no"])
- AC_MSG_RESULT($enable_debug)
- if test "$enable_debug" = "yes"
- then
- AC_DEFINE(DEBUG)
+ AS_HELP_STRING([--enable-debug],[Enable debug mode (not symbols, but portions of the code that are only used in debug builds) (default: no)]),
+ [debug_ok=$enableval], [debug_ok=no])
+
+ if test "$debug_ok" = "yes" -o "${DEBUG}" = 1; then
+ DEBUG=1
+ AC_MSG_RESULT([yes])
+ else
+ DEBUG=0
+ AC_MSG_RESULT([no])
  fi
+
+ AC_DEFINE_UNQUOTED([DEBUG], [$DEBUG], [Debug enabled?])
+ #trap '' DEBUG
+])
+
+AC_DEFUN([ENABLE_UNLOAD], [
+ #trap 'echo "val: (${enable_unload+set}), unload_ok: ($unload_ok), UNLOAD: ($UNLOAD)"' DEBUG
+ AC_MSG_CHECKING([whether to support unloading])
+ AC_ARG_ENABLE(unload,
+ AS_HELP_STRING([--enable-unload],[Add support for unloading this shared library (default: no)]),
+ [unload_ok=$enableval], [unload_ok=no])
+
+ if test "$unload_ok" = "yes" -o "${UNLOAD}" = 1; then
+ UNLOAD=1
+ AC_MSG_RESULT([yes])
+ else
+ UNLOAD=0
+ AC_MSG_RESULT([no])
+ fi
+
+ AC_DEFINE_UNQUOTED([UNLOAD], [$UNLOAD], [Unload enabled?])
+ #trap '' DEBUG
 ])
 
 AC_DEFUN([TIP445], [

configure.ac

@@ -19,16 +19,14 @@ dnl to configure the system for the local environment.
 # so that we create the export library with the dll.
 #-----------------------------------------------------------------------
 
-AC_INIT([rl_json],[0.12.0])
+AC_INIT([rl_json],[0.12.1])
 
 #--------------------------------------------------------------------
 # Call TEA_INIT as the first TEA_ macro to set up initial vars.
 # This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
 # as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
 #--------------------------------------------------------------------
 
-CHECK_DEBUG
-
 TEA_INIT()
 
 AC_CONFIG_AUX_DIR(tclconfig)
@@ -66,6 +64,8 @@ TEA_SETUP_COMPILER
 # Check for feature toggles
 ENABLE_ENSEMBLE
 ENABLE_DEDUP
+ENABLE_DEBUG
+ENABLE_UNLOAD
 
 #-----------------------------------------------------------------------
 # __CHANGE__

generic/api.c

@@ -1098,17 +1098,14 @@ int JSON_Keys(Tcl_Interp* interp, Tcl_Obj* obj, Tcl_Obj* path, Tcl_Obj** keyslis
 int JSON_Decode(Tcl_Interp* interp, Tcl_Obj* bytes, Tcl_Obj* encoding, Tcl_Obj** decodedstring) //{{{
 {
  struct interp_cx* l = Tcl_GetAssocData(interp, "rl_json", NULL);
- Tcl_Obj* ov[4];
- int i, retval;
-
- ov[0] = l->apply;
- ov[1] = l->decode_bytes;
- ov[2] = bytes;
- ov[3] = encoding;
-
- for (i=0; i<4 && ov[i]; i++) if (ov[i]) Tcl_IncrRefCount(ov[i]);
- retval = Tcl_EvalObjv(interp, i, ov, TCL_EVAL_GLOBAL);
- for (i=0; i<4 && ov[i]; i++) release_tclobj(&ov[i]);
+ Tcl_Obj* ov[4] = {l->apply, l->decode_bytes};
+ int retval;
+
+ replace_tclobj(&ov[2], bytes);
+ replace_tclobj(&ov[3], encoding);
+ retval = Tcl_EvalObjv(interp, encoding ? 4 : 3, ov, TCL_EVAL_GLOBAL);
+ replace_tclobj(&ov[2], NULL);
+ replace_tclobj(&ov[3], NULL);
 
  if (retval == TCL_OK) {
  replace_tclobj(decodedstring, Tcl_GetObjResult(interp));

generic/json_types.c

@@ -1,6 +1,90 @@
 #include "rl_jsonInt.h"
 #include "parser.h"
 
+#if UNLOAD
+TCL_DECLARE_MUTEX(g_instances_mutex);
+Tcl_HashTable g_instances;
+int g_instances_initialized = 0;
+
+static void record_instance(Tcl_Obj* obj) //{{{
+{
+_Pragma("GCC diagnostic push");
+_Pragma("GCC diagnostic ignored \"-Wunused-but-set-variable\"");
+ Tcl_HashEntry* he;
+_Pragma("GCC diagnostic pop");
+ int isnew;
+
+ //DBG("Recording instance %s: %p\n", name(obj), obj);
+ Tcl_MutexLock(&g_instances_mutex);
+ he = Tcl_CreateHashEntry(&g_instances, obj, &isnew);
+ Tcl_MutexUnlock(&g_instances_mutex);
+}
+
+//}}}
+static void release_instance(Tcl_Obj* obj) //{{{
+{
+ Tcl_HashEntry* he;
+
+ //DBG("--> Releasing instance %s: %p\n", name(obj), obj);
+ Tcl_MutexLock(&g_instances_mutex);
+ he = Tcl_FindHashEntry(&g_instances, obj);
+ if (!he) Tcl_Panic("rl_json release_instance: No record found for instance %p", obj);
+ Tcl_DeleteHashEntry(he);
+ Tcl_MutexUnlock(&g_instances_mutex);
+ //DBG("<-- Releasing instance %s: %p\n", name(obj), obj);
+}
+
+//}}}
+void release_instances(void) // transmute all remaining json objtypes to pure strings {{{
+{
+ Tcl_HashEntry* he = NULL;
+ Tcl_HashSearch search;
+
+ Tcl_MutexLock(&g_instances_mutex);
+ if (g_instances_initialized) {
+ const char* hashstats = Tcl_HashStats(&g_instances);
+ DBG("------> orphan all remaining instances\n");
+ DBG("g_instances stats:\n%s\n", hashstats);
+ ckfree(hashstats);
+ // Have to re-start the search each time because freeing an intrep
+ // could cascade to freeing other instances, which we would then
+ // walk into in with Tcl_NextHashEntry
+ while ((he = Tcl_FirstHashEntry(&g_instances, &search))) {
+ Tcl_Obj* obj = (Tcl_Obj*)Tcl_GetHashKey(&g_instances, he);
+ DBG("Orphan %-25s refCount %d, stringrep? %d >%s<\n", name(obj), obj->refCount, Tcl_HasStringRep(obj), Tcl_GetString(obj));
+ if (!Tcl_HasStringRep(obj)) Tcl_GetString(obj); // Ensure obj has a valid stringrep
+ Tcl_FreeInternalRep(obj);
+ }
+ DBG("<------ orphan all remaining instances\n");
+ Tcl_DeleteHashTable(&g_instances);
+ g_instances_initialized = 0;
+ }
+ Tcl_MutexUnlock(&g_instances_mutex);
+ Tcl_MutexFinalize(&g_instances_mutex);
+}
+
+//}}}
+static void init_instances() //{{{
+{
+ if (!g_instances_initialized) {
+ Tcl_MutexLock(&g_instances_mutex);
+ if (!g_instances_initialized) {
+ Tcl_InitHashTable(&g_instances, TCL_ONE_WORD_KEYS);
+ g_instances_initialized = 1;
+ }
+ Tcl_MutexUnlock(&g_instances_mutex);
+ }
+}
+
+//}}}
+#else
+#define record_instance(obj)
+#define release_instance(obj)
+void release_instances(void){}
+#define init_instances()
+#endif
+
+
 static void free_internal_rep(Tcl_Obj* obj, Tcl_ObjType* objtype);
 static void dup_internal_rep(Tcl_Obj* src, Tcl_Obj* dest, Tcl_ObjType* objtype);
 static void update_string_rep(Tcl_Obj* obj, Tcl_ObjType* objtype);
@@ -235,7 +319,7 @@ int JSON_SetIntRep(Tcl_Obj* target, enum json_types type, Tcl_Obj* replacement)
  // ptr2 holds the template actions, if any have been generated for this value 
  replace_tclobj((Tcl_Obj**)&intrep.twoPtrValue.ptr1, rep);
 
- Tcl_StoreInternalRep(target, objtype, &intrep);
+ Tcl_StoreInternalRep(target, objtype, &intrep); record_instance(target);
 
  Tcl_InvalidateStringRep(target);
 
@@ -316,6 +400,7 @@ static void free_internal_rep(Tcl_Obj* obj, Tcl_ObjType* objtype) //{{{
  Tcl_DecrRefCount((Tcl_Obj*)ir->twoPtrValue.ptr2); ir->twoPtrValue.ptr2 = NULL;}
 #endif
  }
+ release_instance(obj);
 }
 
 //}}}
@@ -353,7 +438,7 @@ static void dup_internal_rep(Tcl_Obj* src, Tcl_Obj* dest, Tcl_ObjType* objtype)
  if (destir.twoPtrValue.ptr1) Tcl_IncrRefCount((Tcl_Obj*)destir.twoPtrValue.ptr1);
  if (destir.twoPtrValue.ptr2) Tcl_IncrRefCount((Tcl_Obj*)destir.twoPtrValue.ptr2);
 
- Tcl_StoreInternalRep(dest, objtype, &destir);
+ Tcl_StoreInternalRep(dest, objtype, &destir); record_instance(dest);
 }
 
 //}}}
@@ -509,7 +594,7 @@ static int set_from_any(Tcl_Interp* interp, Tcl_Obj* obj, Tcl_ObjType** objtype,
  *out_type = JSON_NUMBER;
  *objtype = g_objtype_for_type[JSON_NUMBER];
 
- Tcl_StoreInternalRep(obj, *objtype, &ir);
+ Tcl_StoreInternalRep(obj, *objtype, &ir); record_instance(obj);
  return TCL_OK;
  }
  }
@@ -717,7 +802,7 @@ static int set_from_any(Tcl_Interp* interp, Tcl_Obj* obj, Tcl_ObjType** objtype,
  release_tclobj((Tcl_Obj**)&ir.twoPtrValue.ptr2);
  release_tclobj(&cx[0].val);
 
- Tcl_StoreInternalRep(obj, top_objtype, &ir);
+ Tcl_StoreInternalRep(obj, top_objtype, &ir); record_instance(obj);
  *objtype = top_objtype;
  *out_type = cx[0].container;
  }
@@ -773,8 +858,9 @@ Tcl_Obj* get_unshared_val(Tcl_ObjInternalRep* ir) //{{{
 
 int init_types(Tcl_Interp* interp) //{{{
 {
- // We don't define set_from_any callbacks for our types, so they must not be Tcl_RegisterObjType'ed
+ init_instances();
 
+ // We don't define set_from_any callbacks for our types, so they must not be Tcl_RegisterObjType'ed
  g_objtype_for_type[JSON_UNDEF] = NULL;
  g_objtype_for_type[JSON_OBJECT] = &json_object;
  g_objtype_for_type[JSON_ARRAY] = &json_array;

generic/names.c

@@ -352,6 +352,26 @@ static void init()
 }
 
 
+void names_shutdown()
+{
+ Tcl_MutexLock(&things_mutex);
+ if (hash_tables_initialized) {
+ Tcl_HashEntry* he;
+ Tcl_HashSearch search;
+
+ for (he = Tcl_FirstHashEntry(&things, &search); he; he = Tcl_NextHashEntry(&search)) {
+ char* chosen = Tcl_GetHashValue(he);
+ ckfree(chosen);
+ }
+ Tcl_DeleteHashTable(&things);
+ Tcl_DeleteHashTable(&names);
+ hash_tables_initialized = 0;
+ }
+ Tcl_MutexUnlock(&things_mutex);
+ Tcl_MutexFinalize(&things_mutex);
+}
+
+
 const char* randwords()
 {
  const int maxlen = 41;

generic/names.h

@@ -1,7 +1,10 @@
 #ifndef _NAMES_H
 #define _NAMES_H
+#if DEBUG
 
 const char* name(const void *const thing); // name given thing
 void* thing(const char *const name); // thing given name
+void names_shutdown();
 
 #endif
+#endif