Tcl Library Source Code

Artifact 6a09e67bb6f7043193593b11ba8b4be15561856a:

Attachment "json2.c" to ticket [6efa4f571a] added by anonymous 2013-12-10 15:04:53. (unpublished)

---

#include <assert.h>
#include <tcl.h>
#include <string.h>
#include <stdio.h>

#include <json-c/json.h>

Tcl_AppInitProc	Json2dict_Init;
static Tcl_ObjCmdProc json2dict;
static Tcl_FreeInternalRepProc jsoncfree;
static Tcl_UpdateStringProc jsonc2string;
static Tcl_DupInternalRepProc jsoncdup;
static Tcl_Obj *value2obj(Tcl_Interp *, struct json_object *);

static Tcl_ObjType json_t = {
	.name = "json-c",
	.freeIntRepProc = jsoncfree,
	.dupIntRepProc = jsoncdup,
	.updateStringProc = jsonc2string
};

#define tcl2jso(O)	(O->internalRep.twoPtrValue.ptr1)

void
jsoncfree(Tcl_Obj *O)
{
	assert(O->typePtr == &json_t);
	json_object_put(tcl2jso(O));
}

void
jsoncdup(Tcl_Obj *src, Tcl_Obj *dst)
{
	assert(src->typePtr == &json_t);
	dst->bytes = src->bytes;
	dst->length = src->length;
	dst->typePtr = &json_t;
	Tcl_IncrRefCount(src);
}

void
jsonc2string(Tcl_Obj *O)
{
	json_object	*jso = tcl2jso(O);
	Tcl_Obj     	*copy;

	assert(O->typePtr == &json_t);

	copy = value2obj(NULL, jso);
	O->typePtr = copy->typePtr;
	O->bytes = Tcl_GetStringFromObj(copy, &O->length);
	json_object_put(tcl2jso(O));
	memcpy(&O->internalRep, &copy->internalRep, sizeof(O->internalRep));
	copy->bytes = NULL;
	copy->length = 0;
	copy->typePtr = NULL;
	Tcl_DecrRefCount(copy);
}

static Tcl_Obj *
jsoncNewObj(struct json_object *jso)
{
	Tcl_Obj	*result = Tcl_NewObj();

	result->bytes = NULL;
	result->typePtr = &json_t;
	tcl2jso(result) = json_object_get(jso);

	return result;
}

Tcl_Obj *
value2obj(Tcl_Interp *I, struct json_object *jso)
{
	Tcl_Obj *result, *key, *value;
	int	 len;
	struct array_list *ar;

	switch (json_object_get_type(jso)) {
	case json_type_object:
		result = Tcl_NewDictObj();
		json_object_object_foreach(jso, k, v) {
			key = Tcl_NewStringObj(k, -1);
			switch (json_object_get_type(v)) {
			case json_type_object:
			case json_type_array:
				value = jsoncNewObj(v);
				break;
			default:
				value = value2obj(I, v);
			}
			Tcl_DictObjPut(I, result, key, value);
		//	json_object_object_del(jso, k);
		}
		return result;
	case json_type_null:
		result = Tcl_NewObj();
		break;
	case json_type_boolean:
		result = Tcl_NewBooleanObj(json_object_get_boolean(jso));
		break;
	case json_type_double:
		result = Tcl_NewDoubleObj(json_object_get_double(jso));
		break;
	case json_type_int:
		result = Tcl_NewWideIntObj(json_object_get_int64(jso));
		break;
	case json_type_array:
		ar = json_object_get_array(jso);
		result = Tcl_NewListObj(0, NULL);
		for (len = 0; len < ar->length; len++) {
			switch (json_object_get_type(ar->array[len])) {
			case json_type_object:
			case json_type_array:
				value = jsoncNewObj(ar->array[len]);
				break;
			default:
				value = value2obj(I, ar->array[len]);
			}
			Tcl_ListObjAppendElement(I, result, value);
		}
		return result;
	case json_type_string:
		len = json_object_get_string_len(jso);
		result = Tcl_NewStringObj(json_object_get_string(jso), len);
	}
	return result; /* unreachable */
}

int
json2dict(ClientData cd, Tcl_Interp *I, int objc, Tcl_Obj * const *objv)
{
	struct json_tokener	*tok;
	enum json_tokener_error	 jerr;
	struct json_object	*parsed;
	const char		*text;
	int       		 len;
	Tcl_Obj            	*result;

	if (objc != 2) {
		Tcl_WrongNumArgs(I, 1, objv, "JSON-text");
		return TCL_ERROR;
	}

	text = Tcl_GetStringFromObj(objv[1], &len);
	tok = json_tokener_new();
	parsed = json_tokener_parse_ex(tok, text, len);

	if (parsed == NULL) {
		jerr = json_tokener_get_error(tok);
		Tcl_SetResult(I,
		    (void *)json_tokener_error_desc(jerr),
		    TCL_STATIC);
		json_tokener_free(tok);
		return TCL_ERROR;
	}
	json_tokener_free(tok);

	result = value2obj(I, parsed);
	json_object_put(parsed);

	Tcl_SetObjResult(I, result);

	return TCL_OK;
}

int Json2dict_Init(Tcl_Interp *I)
{
	Tcl_CreateObjCommand(I, "json-c::json2dict", json2dict, NULL, NULL);

	/*
	 * Conversion from string needs to be implemented before we can
	 * safely register the "json-c" type with Tcl:
	 */
	if (json_t.setFromAnyProc)
		Tcl_RegisterObjType(&json_t);

	return Tcl_PkgProvide(I, "json_bin", "1.1");
}