luatcl.c

#define LUA_LIB
#include <lua.h>
#include <lauxlib.h>
#include <lualib.h>

#include <Tcl.h>

#include <ctype.h>
#include <string.h>


#define LTCL_BUFFERSIZE  64

#define LTCL_INTERP "tcl.Interp"
#define LTCL_OBJECT "tcl.Object"

typedef struct ltcl_State {
    Tcl_Interp  *interp;
    lua_State   *L;
    const Tcl_ObjType *type_OldBoolean;
    const Tcl_ObjType *type_Boolean;
    const Tcl_ObjType *type_ByteArray;
    const Tcl_ObjType *type_Double;
    const Tcl_ObjType *type_Int;
    const Tcl_ObjType *type_WideInt;
    const Tcl_ObjType *type_List;
    const Tcl_ObjType *type_String;
} ltcl_State;

typedef struct ltcl_Object {
    ltcl_State *S;
    Tcl_Obj *obj;
} ltcl_Object;

typedef struct ltcl_Buffer {
    size_t capacity;
    size_t argc;
    lua_State *L;
    Tcl_Obj **argv;
    Tcl_Obj *init_buffer[LTCL_BUFFERSIZE];
} ltcl_Buffer;

static const Tcl_ObjType ltcl_LuaObjectType;

static Tcl_Obj *ltcl_NewLuaObj(lua_State *L);

static int ltcl_luaCmd(ClientData cdata,
        Tcl_Interp *interp, int argc, Tcl_Obj *const*argv);
static int ltcl_luaprocCmd(ClientData cdata,
        Tcl_Interp *interp, int argc, Tcl_Obj *const*argv);


#if LUA_VERSION_NUM <= 502
# define LUA_OK 0

static void luaL_setfuncs(lua_State *L, luaL_Reg *l, int nup) {
    luaL_checkstack(L, nup, "too many upvalues");
    for (; l->name != NULL; l++) {  /* fill the table with given functions */
        int i;
        for (i = 0; i < nup; i++)  /* copy upvalues to the top */
            lua_pushvalue(L, -nup);
        lua_pushcclosure(L, l->func, nup);  /* closure with those upvalues */
        lua_setfield(L, -(nup + 2), l->name);
    }
    lua_pop(L, nup);  /* remove upvalues */
}

static int lua_absindex(lua_State *L, int idx) {
    return (idx > 0 || idx <= LUA_REGISTRYINDEX)
        ? idx
        : idx + lua_gettop(L) + 1;
}

static int ltcl_relindex(int idx, int onstack) {
    return (idx > 0 || idx <= LUA_REGISTRYINDEX)
        ? idx
        : idx - onstack;
}

static int lua_isinteger(lua_State *L, int idx) {
    lua_Number n = lua_tonumber(L, idx);
    lua_Integer i = (lua_Integer)n;
    return (lua_Number)i == n;
}

static void lua_rawgetp(lua_State *L, int idx, const void *p) {
    lua_pushlightuserdata(L, (void*)p);
    lua_rawget(L, ltcl_relindex(idx, 1));
}

static void lua_rawsetp(lua_State *L, int idx, const void *p) {
    lua_pushlightuserdata(L, (void*)p);
    lua_insert(L, -2);
    lua_rawset(L, ltcl_relindex(idx, 1));
}

static void *luaL_testudata (lua_State *L, int ud, const char *tname) {
    void *p = lua_touserdata(L, ud);
    if (p != NULL) {  /* value is a userdata? */
        if (lua_getmetatable(L, ud)) {  /* does it have a metatable? */
            luaL_getmetatable(L, tname);  /* get correct metatable */
            if (!lua_rawequal(L, -1, -2))  /* not the same? */
                p = NULL;  /* value is a userdata with wrong metatable */
            lua_pop(L, 2);  /* remove both metatables */
            return p;
        }
    }
    return NULL;  /* value is not a userdata with a metatable */
}

static void luaL_setmetatable (lua_State *L, const char *tname) {
    luaL_getmetatable(L, tname);
    lua_setmetatable(L, -2);
}

static const char *luaL_tolstring(lua_State *L, int idx, size_t *plen) {
    if (!luaL_callmeta(L, idx, "__tostring")) {  /* no metafield? */
        switch (lua_type(L, idx)) {
        case LUA_TNUMBER:
        case LUA_TSTRING:
            lua_pushvalue(L, idx);
            break;
        case LUA_TBOOLEAN:
            lua_pushstring(L, (lua_toboolean(L, idx) ? "true" : "false"));
            break;
        case LUA_TNIL:
            lua_pushliteral(L, "nil");
            break;
        default:
            lua_pushfstring(L, "%s: %p", luaL_typename(L, idx),
                    lua_topointer(L, idx));
            break;
        }
    }
    return lua_tolstring(L, -1, plen);
}

static int luaL_requiref(lua_State *L, const char *name, lua_CFunction loader, int glb) {
    lua_getfield(L, LUA_REGISTRYINDEX, "_LOADED"); /* 1 */
    lua_getfield(L, -1, name);
    if (lua_type(L, -1) != LUA_TNIL) { /* 2 */
        lua_remove(L, -2); /* (1) */
        return 0;
    }
    lua_pop(L, 1);
    lua_pushstring(L, name); /* 2 */
    lua_pushcfunction(L, loader); /* 3 */
    lua_pushvalue(L, -2); /* 2->4 */
    lua_call(L, 1, 1); /* 3,4->3 */
    lua_pushvalue(L, -1); /* 3->4 */
    lua_insert(L, -4); /* 4->1 */
    /* stack: lib _LOADED name lib */
    lua_rawset(L, -3); /* 3,4->2 */
    lua_pop(L, 1); /* (2) */
    return 1;
}

#ifdef LUA_BITSINT /* not LuaJIT */
/* LuaJIT has its own luaL_traceback() */
#define LEVELS1	12	/* size of the first part of the stack */
#define LEVELS2	10	/* size of the second part of the stack */
static void luaL_traceback(lua_State *L, lua_State *L1, const char *msg, int level) {
    int top = lua_gettop(L);
    int firstpart = 1;  /* still before eventual `...' */
    lua_Debug ar;
    if (msg) lua_pushfstring(L, "%s\n", msg);
    lua_pushliteral(L, "stack traceback:");
    while (lua_getstack(L1, level++, &ar)) {
        if (level > LEVELS1 && firstpart) {
            /* no more than `LEVELS2' more levels? */
            if (!lua_getstack(L1, level+LEVELS2, &ar))
                level--;  /* keep going */
            else {
                lua_pushliteral(L, "\n\t...");  /* too many levels */
                while (lua_getstack(L1, level+LEVELS2, &ar))  /* find last levels */
                    level++;
            }
            firstpart = 0;
            continue;
        }
        lua_pushliteral(L, "\n\t");
        lua_getinfo(L1, "Snl", &ar);
        lua_pushfstring(L, "%s:", ar.short_src);
        if (ar.currentline > 0)
            lua_pushfstring(L, "%d:", ar.currentline);
        if (*ar.namewhat != '\0')  /* is there a name? */
            lua_pushfstring(L, " in function " LUA_QS, ar.name);
        else {
            if (*ar.what == 'm')  /* main? */
                lua_pushfstring(L, " in main chunk");
            else if (*ar.what == 'C' || *ar.what == 't')
                lua_pushliteral(L, " ?");  /* C function or tail call */
            else
                lua_pushfstring(L, " in function <%s:%d>",
                        ar.short_src, ar.linedefined);
        }
        lua_concat(L, lua_gettop(L) - top);
    }
    lua_concat(L, lua_gettop(L) - top);
}
#endif /* LUA_BITSINT */

#endif

#if LUA_VERSION_NUM <= 503
static int lua53_rawget(lua_State *L, int idx)
{ lua_rawget(L, idx); return lua_type(L, -1); }
static int lua53_rawgeti(lua_State *L, int idx, int i)
{ lua_rawgeti(L, idx, i); return lua_type(L, -1); }
static int lua53_rawgetp(lua_State *L, int idx, const void *p)
{ lua_rawgetp(L, idx, p); return lua_type(L, -1); }
#else
# define lua53_rawget  lua_rawget
# define lua53_rawgeti lua_rawgeti
# define lua53_rawgetp lua_rawgetp
#endif

/* utils */

#define ltcl_returnself(L) do { lua_settop(L, 1); return 1; } while (0)

static int ltcl_typeerror(lua_State *L, int idx, const char *tname) {
    lua_pushfstring(L, "%s expected, got %s", tname, luaL_typename(L, idx));
    return luaL_argerror(L, idx, lua_tostring(L, -1));
}

static ltcl_State *ltcl_checkstate(lua_State *L, int idx) {
    ltcl_State *S = (ltcl_State*)luaL_checkudata(L, idx, LTCL_INTERP);
    if (S->interp == NULL)
        luaL_argerror(L, idx, "invalid Tcl interpreter");
    return S;
}

static Tcl_Encoding ltcl_checkencoding(lua_State *L, ltcl_State *S, int idx) {
    Tcl_Encoding enc = NULL;
    const char *s = luaL_optstring(L, idx, NULL);
    if (s != NULL) {
        enc = Tcl_GetEncoding(S->interp, s);
        if (enc == NULL) {
            /*Tcl_ResetResult(S->interp);*/
            /*enc = Tcl_GetEncoding(S->interp, s);*/
            luaL_argerror(L, idx, Tcl_GetStringResult(S->interp));
        }
    }
    return enc;
}

static int ltcl_traceback(lua_State *L) {
    const char *msg = lua_tostring(L, 1);
    if (msg)
        luaL_traceback(L, L, msg, 1);
    else if (!lua_isnoneornil(L, 1)) {
        if (!luaL_callmeta(L, 1, "__tostring"))
            lua_pushliteral(L, "(no error message)");
    }
    return 1;
}


/* tcl buffer */

#define LTCL_BOX  "Tcl.Box"

#define ltcl_buffonstack(B) ((B)->argv != (B)->init_buffer)

static Tcl_Obj *ltcl_testobject(lua_State *L, int idx);

static int ltcl_freebox(lua_State *L) {
    Tcl_Obj ***objs = (Tcl_Obj***)luaL_testudata(L, 1, LTCL_BOX);
    if (objs && *objs) {
        ckfree(*objs);
        *objs = NULL;
    }
    return 0;
}

static Tcl_Obj **ltcl_newbox(lua_State *L, size_t size) {
    Tcl_Obj ***objs = (Tcl_Obj***)lua_newuserdata(L, sizeof(Tcl_Obj**));
    *objs = (Tcl_Obj**)ckalloc(size * sizeof(Tcl_Obj*));
    if (luaL_newmetatable(L, LTCL_BOX)) {
        lua_pushcfunction(L, ltcl_freebox);
        lua_setfield(L, -2, "__gc");
    }
    lua_setmetatable(L, -2);
    return *objs;
}

static Tcl_Obj **ltcl_resizebox(lua_State *L, size_t newsize) {
    Tcl_Obj ***objs = (Tcl_Obj***)luaL_checkudata(L, -1, LTCL_BOX);
    return *objs = (Tcl_Obj**)ckrealloc(*objs, newsize * sizeof(Tcl_Obj*));
}

static void ltcl_buffinit(lua_State *L, ltcl_Buffer *B) {
    B->L = L;
    B->capacity = LTCL_BUFFERSIZE;
    B->argc = 0;
    B->argv = B->init_buffer;
}

static Tcl_Obj **ltcl_prepbuffsize(ltcl_Buffer *B, size_t size) {
    if (B->argc + size > B->capacity) {
        lua_State *L = B->L;
        size_t newsize = B->capacity*2;
        while (newsize < B->argc + size) {
            if (newsize >= ~(size_t)0/2)
                luaL_error(L, "buffer too big");
            newsize *= 2;
        }
        if (ltcl_buffonstack(B))
            B->argv = ltcl_resizebox(L, newsize);
        else {
            B->argv = ltcl_newbox(L, newsize);
            memcpy(B->argv, B->init_buffer, B->argc*sizeof(Tcl_Obj*));
        }
        B->capacity = newsize;
    }
    return &B->argv[B->argc];
}

static void ltcl_addobject(ltcl_Buffer *B, Tcl_Obj *obj) {
    Tcl_IncrRefCount(obj);
    *ltcl_prepbuffsize(B, 1) = obj;
    ++B->argc;
}

static void ltcl_addarraypart(ltcl_Buffer *B, int idx) {
    lua_State *L = B->L;
    int i;
    for (i = 1; lua53_rawgeti(L, idx, i) != LUA_TNIL; ++i) {
        Tcl_Obj *obj = ltcl_testobject(L, -1);
        if (obj == NULL) {
            lua_pushfstring(L, "invalid Tcl object at #%d in table", i);
            luaL_argerror(L, idx, lua_tostring(L, -1));
        }
        lua_pop(L, 1);
        ltcl_addobject(B, obj);
    }
    lua_pop(L, 1);
}

static void ltcl_addhashpart(ltcl_Buffer *B, int idx) {
    int onstack;
    lua_State *L = B->L;
    if (!(onstack = ltcl_buffonstack(B)))
        lua_pushnil(L); /* place holder for buffer */
    lua_pushnil(L);
    while (lua_next(L, idx)) {
        if (lua_type(L, -2) == LUA_TSTRING) {
            size_t len;
            const char *s = lua_tolstring(L, -2, &len);
            Tcl_Obj *key, *value = ltcl_testobject(L, -1);
            if (value == NULL) {
                lua_pushfstring(L, "invalid Tcl object ('%s') in table", s);
                luaL_argerror(L, idx, lua_tostring(L, -1));
            }
            key = Tcl_NewObj();
            key->bytes = (char*)ckalloc(len + 2);
            key->bytes[0] = '-';
            memcpy(key->bytes+1, s, len+1);
            key->length = len+1;
            if (onstack) lua_pushvalue(L, -3);
            ltcl_addobject(B, key);
            ltcl_addobject(B, value);
            if (onstack) lua_pop(L, 1);
            else if ((onstack = ltcl_buffonstack(B)))
                lua_replace(L, -4);
        }
        lua_pop(L, 1);
    }
}

static void ltcl_freeobjects(ltcl_Buffer *B) {
    size_t i;
    for (i = 0; i < B->argc; ++i)
        Tcl_DecrRefCount(B->argv[i]);
}


/* tcl object */

static ltcl_Object *ltcl_newobject(lua_State *L, ltcl_State *S, Tcl_Obj *obj) {
    ltcl_Object *lobj = (ltcl_Object*)lua_newuserdata(L, sizeof(ltcl_Object));
    lobj->S = S;
    lobj->obj = obj;
    Tcl_Preserve(obj);
    Tcl_IncrRefCount(obj);
    luaL_setmetatable(L, LTCL_OBJECT);
    return lobj;
}

static int ltcl_pushobject(lua_State *L, ltcl_State *S, Tcl_Obj *obj) {
    int len;
    const Tcl_ObjType *type;
    if (obj == NULL)
        lua_pushnil(L);
    else if ((type = obj->typePtr) == NULL || type == S->type_ByteArray) {
        const char *s = (const char*)Tcl_GetByteArrayFromObj(obj, &len);
        lua_pushlstring(L, s, len);
    }
    else if (type == S->type_String) {
        const char *s = (const char*)Tcl_GetStringFromObj(obj, &len);
        lua_pushlstring(L, s, len);
    }
    else if (type == S->type_Boolean || type == S->type_OldBoolean)
        goto push_boolean;
    else if (type == S->type_Int)
        lua_pushinteger(L, obj->internalRep.longValue);
    else if (type == S->type_WideInt)
        lua_pushinteger(L, obj->internalRep.wideValue);
    else if (type == S->type_Double)
        lua_pushinteger(L, obj->internalRep.doubleValue);
    else if (type == S->type_List) {
        int i, objc;
        Tcl_Obj **objv;
        Tcl_ListObjGetElements(NULL, obj, &objc, &objv);
        lua_createtable(L, objc, 0);
        for (i = 0; i < objc; ++i) {
            ltcl_pushobject(L, S, objv[i]);
            lua_rawseti(L, -2, i + 1);
        }
    }
    else if (type == &ltcl_LuaObjectType) {
        lua_rawgeti(L, LUA_REGISTRYINDEX,
                (int)obj->internalRep.ptrAndLongRep.value);
    }
    else {
#if TK_HEX_VERSION >= 0x08050000
        if (S->type_Boolean == NULL &&
                strcmp(obj->typePtr->name, "booleanString") == 0) {
            S->type_Boolean = obj->typePtr;
            goto push_boolean;
        }
#endif
        ltcl_newobject(L, S, obj);
    }
    return 1;

push_boolean:
    if (Tcl_GetBooleanFromObj(S->interp, obj, &len) == TCL_OK)
        lua_pushboolean(L, len);
    else {
        const char *s = (const char*)Tcl_GetByteArrayFromObj(obj, &len);
        lua_pushlstring(L, s, len);
    }
    return 1;
}

static int ltcl_pushresult(lua_State *L, ltcl_State *S, int res) {
    Tcl_Obj *ret;
    if (res != TCL_OK) {
        lua_pushnil(L);
        lua_pushstring(L, Tcl_GetStringResult(S->interp));
        return 2;
    }
    if ((ret = Tcl_GetObjResult(S->interp)) == NULL)
        return 0;
    return ltcl_pushobject(L, S, ret);
}

static Tcl_Obj *ltcl_toprimitive(lua_State *L, int idx, int type) {
    size_t len;
    const char *s;
    ltcl_Object *lobj;
    switch (type) {
    case LUA_TNIL:
        return Tcl_NewObj();
    case LUA_TBOOLEAN:
        return Tcl_NewBooleanObj(lua_toboolean(L, idx));
    case LUA_TNUMBER:
        if (!lua_isinteger(L, idx))
            return Tcl_NewDoubleObj(lua_tonumber(L, idx));
        else if (sizeof(lua_Integer) == sizeof(Tcl_WideInt)) /* XXX */
            return Tcl_NewWideIntObj(lua_tointeger(L, idx));
        else
            return Tcl_NewIntObj(lua_tointeger(L, idx));
    case LUA_TSTRING:
        s = lua_tolstring(L, idx, &len);
        return Tcl_NewByteArrayObj((unsigned char*)s, len);
    case LUA_TUSERDATA:
        lobj = (ltcl_Object*)luaL_testudata(L, idx, LTCL_OBJECT);
        if (lobj != NULL && lobj->obj != NULL)
            return lobj->obj;
        /* FALLTHROUGH */
    default:
        lua_pushvalue(L, idx);
        return ltcl_NewLuaObj(L);
    }
    return NULL;
}

static Tcl_Obj *ltcl_table2list(lua_State *L, int idx, ltcl_Buffer *B) {
    int type, i, j;
    Tcl_Obj *obj, *list = Tcl_NewObj();
    luaL_checkstack(L, 2, "too many level in table");
    for (i = 1; (type = lua53_rawgeti(L, idx, i)) != LUA_TNIL; ++i) {
        if (type == LUA_TTABLE) {
            Tcl_Obj *ptr = (Tcl_Obj*)lua_topointer(L, -1);
            for (j = 0; j < B->argc; ++j)
                if (B->argv[j] == ptr) /* XXX how to collect list? */
                    luaL_error(L, "attempt to convert a recursive table");
            if (ltcl_buffonstack(B)) lua_insert(L, -2);
            *ltcl_prepbuffsize(B, 1) = ptr; ++B->argc;
            obj = ltcl_table2list(L, (ltcl_buffonstack(B) ? -2 : -1), B);
            lua_remove(L, ltcl_buffonstack(B) ? -2 : -1);
        }
        else if ((obj = ltcl_toprimitive(L, -1, type)) != NULL)
            lua_pop(L, 1);
        else luaL_error(L, "attempt to convert a Tcl incompatible value");
        Tcl_ListObjAppendElement(NULL, list, obj);
    }
    lua_pop(L, 1);
    return list;
}

static Tcl_Obj *ltcl_testobject(lua_State *L, int idx) {
    int type = lua_type(L, idx);
    if (type == LUA_TTABLE) {
        ltcl_Buffer B;
        ltcl_buffinit(L, &B);
        B.argv[B.argc++] = (Tcl_Obj*)lua_topointer(L, idx);
        return ltcl_table2list(L, lua_absindex(L, idx), &B);
    }
    return ltcl_toprimitive(L, idx, type);
}

static Tcl_Obj *ltcl_checkobject(lua_State *L, int idx) {
    Tcl_Obj *obj = ltcl_testobject(L, idx);
    if (obj == NULL) ltcl_typeerror(L, idx, "Tcl compatible value");
    return obj;
}

static int Lobj_delete(lua_State *L) {
    ltcl_Object *obj = (ltcl_Object*)luaL_testudata(L, 1, LTCL_OBJECT);
    if (obj && obj->obj) {
        Tcl_DecrRefCount(obj->obj);
        obj->obj = NULL;
    }
    return 0;
}

static int Lobj_type(lua_State *L) {
    int i, top = lua_gettop(L);
    for (i = 1; i <= top; ++i) {
        ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, i, LTCL_OBJECT);
        if (obj->obj && obj->obj->typePtr && obj->obj->typePtr->name)
            lua_pushstring(L, obj->obj->typePtr->name);
        else
            lua_pushnil(L);
        lua_replace(L, i);
    }
    return top;
}

static int Lobj_cast(lua_State *L) {
    ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    const Tcl_ObjType *type = Tcl_GetObjType(luaL_checkstring(L, 2));
    if (type == NULL) {
        lua_pushfstring(L, "no such type '%s'", type);
        luaL_argerror(L, 2, lua_tostring(L, -1));
    }
    if (Tcl_ConvertToType(obj->S->interp, obj->obj, type) == TCL_ERROR)
        return ltcl_pushresult(L, obj->S, TCL_ERROR);
    ltcl_returnself(L);
}

static int Lobj_value(lua_State *L) {
    int i, top = lua_gettop(L);
    for (i = 1; i <= top; ++i) {
        ltcl_Object *obj = (ltcl_Object*)luaL_testudata(L, i, LTCL_OBJECT);
        if (obj) {
            ltcl_pushobject(L, obj->S, obj->obj);
            lua_replace(L, i);
        }
    }
    return top;
}

static int Lobj_tostring(lua_State *L) {
    ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    int len;
    char *s = Tcl_GetStringFromObj(obj->obj, &len);
    lua_pushlstring(L, s, len);
    return 1;
}

static int Lobj_call(lua_State *L) {
    ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    int res, i, top = lua_gettop(L);
    int argc; Tcl_Obj **argv;
    ltcl_Buffer B;
    ltcl_buffinit(L, &B);
    res = Tcl_ListObjGetElements(obj->S->interp,
            obj->obj, &argc, &argv);
    if (res != TCL_OK)
        return ltcl_pushresult(L, obj->S, TCL_ERROR);
    for (i = 0; i < argc; ++i)
        ltcl_addobject(&B, argv[i]);
    for (i = 2; i <= top; ++i)
        ltcl_addobject(&B, ltcl_checkobject(L, i));
    res = ltcl_pushresult(L, obj->S, 
            Tcl_EvalObjv(obj->S->interp, B.argc, B.argv, 0));
    ltcl_freeobjects(&B);
    return res;
}

static int Lobj_clone(lua_State *L) {
    ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    if (obj->obj == NULL) return 0;
    ltcl_newobject(L, obj->S, Tcl_DuplicateObj(obj->obj));
    return 1;
}

static int Lobj_index(lua_State *L) {
    ltcl_Object *obj;
    Tcl_Obj *value;
    int index;
    if (lua_getmetatable(L, 1)) {
        lua_pushvalue(L, 2);
        if (lua53_rawget(L, -2) != LUA_TNIL)
            return 1;
    }
    obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    if (obj->obj == NULL) return 0;
    index = (int)luaL_checkinteger(L, 2);
    if (Tcl_ListObjIndex(obj->S->interp, obj->obj, index, &value) == TCL_ERROR)
        return luaL_error(L, Tcl_GetStringResult(obj->S->interp));
    if (value == NULL) return 0;
    return ltcl_pushobject(L, obj->S, value);
}

static int Lobj_newindex(lua_State *L) {
    ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    int res, index = (int)luaL_checkinteger(L, 2);
    Tcl_Obj *value = ltcl_checkobject(L, 3);
    if (obj->obj == NULL) obj->obj = Tcl_NewObj();
    if (Tcl_IsShared(obj->obj)) {
        Tcl_DecrRefCount(obj->obj);
        obj->obj = Tcl_DuplicateObj(obj->obj);
        Tcl_IncrRefCount(obj->obj);
    }
    res = Tcl_ListObjReplace(obj->S->interp,
            obj->obj, index, 1, 1, &value);
    if (res == TCL_ERROR)
        return luaL_error(L, Tcl_GetStringResult(obj->S->interp));
    return 0;
}

static int Lobj_len(lua_State *L) {
    int size = 0;
    ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    if (obj->obj != NULL
            && Tcl_ListObjLength(obj->S->interp, obj->obj, &size) == TCL_ERROR)
        return luaL_error(L, Tcl_GetStringResult(obj->S->interp));
    lua_pushinteger(L, size);
    return 1;
}

static int Ltcl_object(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    Tcl_Obj *obj;
    int i, top = lua_gettop(L);
    luaL_checkstack(L, top, "too many Tcl objects");
    if (top == 2)
        obj = ltcl_checkobject(L, 2);
    else {
        obj = Tcl_NewObj();
        for (i = 2; i <= top; ++i)
            Tcl_ListObjAppendElement(S->interp, obj, ltcl_checkobject(L, i));
    }
    ltcl_newobject(L, S, obj);
    return 1;
}

static int Lobj_concat(lua_State *L) {
    ltcl_Object *obj = (ltcl_Object*)luaL_checkudata(L, 1, LTCL_OBJECT);
    Tcl_Obj *list;
    int i, top = lua_gettop(L);
    ltcl_Buffer B;
    ltcl_buffinit(L, &B);
    for (i = 1; i <= top; ++i)
        ltcl_addobject(&B, ltcl_checkobject(L, i));
    list = Tcl_ConcatObj(B.argc, B.argv);
    Tcl_DecrRefCount(obj->obj);
    Tcl_IncrRefCount(obj->obj = list);
    ltcl_freeobjects(&B);
    ltcl_returnself(L);
}

static void open_object(lua_State *L) {
    luaL_Reg libs[] = {
        { "__gc",       Lobj_delete   },
        { "__tostring", Lobj_tostring },
        { "__call",     Lobj_call     },
        { "__index",    Lobj_index    },
        { "__newindex", Lobj_newindex },
        { "__len",      Lobj_len      },
#define ENTRY(name) { #name, Lobj_##name }
        ENTRY(delete),
        ENTRY(type),
        ENTRY(cast),
        ENTRY(value),
        ENTRY(clone),
        ENTRY(concat),
#undef  ENTRY
        { NULL, NULL }
    };
    if (luaL_newmetatable(L, LTCL_OBJECT))
        luaL_setfuncs(L, libs, 0);
}


/* tcl lua proc */

typedef struct ltcl_ClientData {
    lua_State  *L;
    ltcl_State *S;
    int ref_func;
} ltcl_ClientData;

static int ltcl_luaproc(ClientData cdata, Tcl_Interp *interp, int argc, Tcl_Obj *const*argv) {
    ltcl_ClientData *ud = (ltcl_ClientData*)cdata;
    lua_State *L = ud->L;
    int i, res;
    luaL_checkstack(L, argc+2, "Too many proc arguments");
    lua_pushcfunction(L, ltcl_traceback);
    lua_rawgeti(L, LUA_REGISTRYINDEX, ud->ref_func);
    for (i = 1; i < argc; ++i)
        ltcl_pushobject(L, ud->S, argv[i]);
    res = lua_pcall(L, argc-1, 1, -argc-1);
    Tcl_SetObjResult(interp, ltcl_testobject(L, -1));
    lua_pop(L, 2);
    return res == LUA_OK ? TCL_OK : TCL_ERROR;
}

static void ltcl_delluaproc(ClientData cdata) {
    ltcl_ClientData *ud = (ltcl_ClientData*)cdata;
    luaL_unref(ud->L, LUA_REGISTRYINDEX, ud->ref_func);
    ckfree(ud);
}

static int Ltcl_proc(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    const char *name = luaL_checkstring(L, 2);
    ltcl_ClientData *ud;
    Tcl_Command cmd;
    if (lua_isnoneornil(L, 3)) {
        Tcl_DeleteCommand(S->interp, name);
        return 0;
    }
    luaL_checktype(L, 3, LUA_TFUNCTION);
    ud = (ltcl_ClientData*)ckalloc(sizeof(ltcl_ClientData));
    lua_settop(L, 3);
    ud->L = L;
    ud->S = S;
    ud->ref_func = luaL_ref(L, LUA_REGISTRYINDEX);
    cmd = Tcl_CreateObjCommand(S->interp, name,
            ltcl_luaproc, (ClientData)ud, ltcl_delluaproc);
    if (cmd == NULL)
        return ltcl_pushresult(L, S, TCL_ERROR);
    ltcl_returnself(L);
}


/* tcl variable access */

static int ltcl_checkaccessflags(lua_State *L, int idx) {
    const char *s = luaL_optstring(L, idx, NULL);
    int flags = 0;
    if (s == NULL) return 0;
    while (*s != '\0') {
        switch (tolower(*s++)) {
        case 'g': flags |= TCL_GLOBAL_ONLY; break;
        case 'n': flags |= TCL_NAMESPACE_ONLY; break;
        case 'a': flags |= TCL_APPEND_VALUE; break;
        case 'l': flags |= TCL_LIST_ELEMENT; break;
        default:
            luaL_argerror(L, idx, "invalid flags, only [gnal]* allowed");
            break;
        }
    }
    return flags;
}

static int ltcl_checktraceflags(lua_State *L, int idx) {
    const char *s = luaL_optstring(L, idx, NULL);
    int flags = 0;
    if (s == NULL) return 0;
    while (*s != '\0') {
        switch (tolower(*s++)) {
        case 'g': flags |= TCL_GLOBAL_ONLY; break;
        case 'n': flags |= TCL_NAMESPACE_ONLY; break;
        case 'a': flags |= TCL_TRACE_ARRAY; break;
        case 'r': flags |= TCL_TRACE_READS; break;
        case 'w': flags |= TCL_TRACE_WRITES; break;
        case 'u': flags |= TCL_TRACE_UNSETS; break;
        default:
            luaL_argerror(L, idx, "invalid flags, only [gnrwau]* allowed");
            break;
        }
    }
    return flags;
}

static void ltcl_pushtraceflags(lua_State *L, int flags) {
    char buff[32], *p = buff;
    if ((flags & TCL_GLOBAL_ONLY) != 0)    *p++ = 'g';
    if ((flags & TCL_NAMESPACE_ONLY) != 0) *p++ = 'n';
    if ((flags & TCL_TRACE_ARRAY) != 0)    *p++ = 'a';
    if ((flags & TCL_TRACE_READS) != 0)    *p++ = 'r';
    if ((flags & TCL_TRACE_WRITES) != 0)   *p++ = 'w';
    if ((flags & TCL_TRACE_UNSETS) != 0)   *p++ = 'u';
    if ((flags & TCL_TRACE_DESTROYED) != 0)  *p++ = 'd';
    if ((flags & TCL_INTERP_DESTROYED) != 0) *p++ = 'D';
    *p = '\0';
    lua_pushstring(L, buff);
}

static int Ltcl_get(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    const char *name1 = luaL_checkstring(L, 2);
    const char *name2 = luaL_optstring(L, 3, NULL);
    int flags = ltcl_checkaccessflags(L, 4)|TCL_LEAVE_ERR_MSG;
    Tcl_Obj *ret = Tcl_GetVar2Ex(S->interp, name1, name2, flags);
    if (ret == NULL) return ltcl_pushresult(L, S, TCL_ERROR);
    return ltcl_pushobject(L, S, ret);
}

static int Ltcl_set(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    const char *name1 = luaL_checkstring(L, 2);
    const char *name2 = luaL_optstring(L, 3, NULL);
    Tcl_Obj *value = lua_isnoneornil(L, 4) ? Tcl_NewObj() : ltcl_checkobject(L, 4);
    int flags = ltcl_checkaccessflags(L, 5)|TCL_LEAVE_ERR_MSG;
    Tcl_Obj *ret = Tcl_SetVar2Ex(S->interp, name1, name2, value, flags);
    if (ret == NULL) return ltcl_pushresult(L, S, TCL_ERROR);
    ltcl_returnself(L);
}

static int Ltcl_unset(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    const char *name1 = luaL_checkstring(L, 2);
    const char *name2 = luaL_optstring(L, 3, NULL);
    int flags = ltcl_checkaccessflags(L, 4)|TCL_LEAVE_ERR_MSG;
    int ret = Tcl_UnsetVar2(S->interp, name1, name2, flags);
    if (ret == TCL_ERROR) return ltcl_pushresult(L, S, TCL_ERROR);
    ltcl_returnself(L);
}

static char *ltcl_luatrace(ClientData cdata, Tcl_Interp *interp, const char *name1, const char *name2, int flags) {
    ltcl_ClientData *ud = (ltcl_ClientData*)cdata;
    lua_State *L = ud->L;
    char *ret = NULL;
    luaL_checkstack(L, 5, "Too many trace arguments");
    lua_pushcfunction(L, ltcl_traceback);
    lua_rawgeti(L, LUA_REGISTRYINDEX, ud->ref_func);
    lua_pushstring(L, name1);
    lua_pushstring(L, name2);
    ltcl_pushtraceflags(L, flags);
    lua_pcall(L, 3, 1, -5);
    if (lua_toboolean(L, -1))
        ret = (char*)ltcl_testobject(L, -1);
    lua_pop(L, 1);
    if ((flags & (TCL_TRACE_DESTROYED|TCL_INTERP_DESTROYED)) != 0) {
        luaL_unref(L, LUA_REGISTRYINDEX, ud->ref_func);
        ckfree(ud);
    }
    return ret;
}

static int Ltcl_trace(lua_State *L) {
    int idx = 1, flags;
    ltcl_State *S = ltcl_checkstate(L, idx++);
    const char *name1 = luaL_checkstring(L, idx++), *name2 = NULL;
    ltcl_ClientData *ud;
    if (lua_type(L, idx) == LUA_TSTRING)
        name2 = lua_tostring(L, idx++);
    luaL_checktype(L, idx, LUA_TFUNCTION);
    flags = ltcl_checktraceflags(L, idx+1)|TCL_TRACE_RESULT_OBJECT;
    lua_settop(L, idx);
    ud = (ltcl_ClientData*)ckalloc(sizeof(ltcl_ClientData));
    ud->L = L;
    ud->S = S;
    ud->ref_func = luaL_ref(L, LUA_REGISTRYINDEX);
    if (Tcl_TraceVar2(S->interp, name1, name2, flags,
                ltcl_luatrace, ud) != TCL_OK)
        return ltcl_pushresult(L, S, TCL_ERROR);
    lua_pushlightuserdata(L, ud);
    return 1;
}

static int Ltcl_untrace(lua_State *L) {
    int idx = 1, flags;
    ltcl_State *S = ltcl_checkstate(L, idx++);
    const char *name1 = luaL_checkstring(L, idx++), *name2 = NULL;
    if (lua_type(L, idx) == LUA_TSTRING)
        name2 = lua_tostring(L, idx++);
    luaL_checktype(L, idx, LUA_TLIGHTUSERDATA);
    flags = ltcl_checktraceflags(L, idx+1);
    Tcl_UntraceVar2(S->interp, name1, name2, flags,
            ltcl_luatrace, lua_touserdata(L, idx));
    ltcl_returnself(L);
}


/* lua module routines */

#define LTCL_STATE_POOL     ((void*)0xFFF7C15B)

static int ltcl_retrieve(ltcl_State *S) {
    lua_rawgetp(S->L, LUA_REGISTRYINDEX, LTCL_STATE_POOL);
    if (lua53_rawgetp(S->L, -1, S) == LUA_TUSERDATA) {
        lua_remove(S->L, -2);
        return 1;
    }
    lua_pop(S->L, 2);
    return 0;
}

static void ltcl_register(lua_State *L, ltcl_State *S) {
    if (lua53_rawgetp(L, LUA_REGISTRYINDEX, LTCL_STATE_POOL) == LUA_TNIL) {
        lua_pop(L, 1);
        lua_createtable(L, 0, 1); /* 1 */
        lua_createtable(L, 0, 1); /* 2 */
        lua_pushfstring(L, "v"); /* 3 */
        lua_setfield(L, -2, "__mode"); /* 3->2 */
        lua_setmetatable(L, -2); /* 2->1 */
        lua_pushvalue(L, -1); /* 1->2 */
        lua_rawsetp(L, LUA_REGISTRYINDEX, LTCL_STATE_POOL); /* 2->registry */
    }
    lua_pushvalue(L, -2);
    lua_rawsetp(L, -2, S);
    lua_pop(L, 1);
}

static ltcl_State *ltcl_newstate(lua_State *L, Tcl_Interp *interp) {
    ltcl_State *S = (ltcl_State*)lua_newuserdata(L, sizeof(ltcl_State));
    S->L = L;
    S->interp = interp;
    S->type_OldBoolean = Tcl_GetObjType("boolean");
    S->type_Boolean    = Tcl_GetObjType("booleanString");
    S->type_ByteArray  = Tcl_GetObjType("bytearray");
    S->type_Double     = Tcl_GetObjType("double");
    S->type_Int        = Tcl_GetObjType("int");
    S->type_WideInt    = Tcl_GetObjType("wideInt");
    S->type_List       = Tcl_GetObjType("list");
    S->type_String     = Tcl_GetObjType("string");
    luaL_setmetatable(L, LTCL_INTERP);
    ltcl_register(L, S);

    Tcl_CreateObjCommand(S->interp, "lua", ltcl_luaCmd, (ClientData)S, NULL);
    Tcl_CreateObjCommand(S->interp, "luaproc", ltcl_luaprocCmd, (ClientData)S, NULL);
    Tcl_SetAssocData(S->interp, "ltcl_State", NULL, S);
    /* XXX should put to some where only run once */
    /*Tcl_RegisterObjType(&ltcl_LuaObjectType);*/
    return S;
}

static int Ltcl_new(lua_State *L) {
    Tcl_Interp *interp = Tcl_CreateInterp();
    if (interp == NULL)
        return luaL_error(L, "create Tcl interpreter failed");
    if (Tcl_Init(interp) == TCL_ERROR) {
        Tcl_DeleteInterp(interp);
        return luaL_error(L, "Tcl initialisation failed");
    }
    ltcl_newstate(L, interp);
    return 1;
}

static int Ltcl_delete(lua_State *L) {
    ltcl_State *S = (ltcl_State*)luaL_testudata(L, 1, LTCL_INTERP);
    if (S && S->interp) {
        Tcl_DeleteInterp(S->interp);
        S->interp = NULL;
    }
    return 0;
}

static int Ltcl_tostring(lua_State *L) {
    ltcl_State *S = (ltcl_State*)luaL_testudata(L, 1, LTCL_INTERP);
    if (S) lua_pushfstring(L, LTCL_INTERP ": %p", S);
    else luaL_tolstring(L, 1, NULL);
    return 1;
}

static int Ltcl_encoding(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    const char *enc = luaL_optstring(L, 2, NULL);
    if (enc == NULL) {
        Tcl_GetEncodingNames(S->interp);
        return ltcl_pushresult(L, S, TCL_OK);
    }
    if (Tcl_SetSystemEncoding(S->interp, enc) == TCL_ERROR)
        return ltcl_pushresult(L, S, TCL_ERROR);
    ltcl_returnself(L);
}

static int Ltcl_fromutf8(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    size_t len;
    const char *d, *s = luaL_checklstring(L, 2, &len);
    Tcl_Encoding enc = ltcl_checkencoding(L, S, 3);
    Tcl_DString dst;
    d = Tcl_UtfToExternalDString(enc, s, len, &dst);
    lua_pushlstring(L, d, Tcl_DStringLength(&dst));
    Tcl_DStringFree(&dst);
    /* XXX use luaL_Buffer? safer, but waste memory */
#if 0
    int reslen;
    luaL_Buffer B;
    luaL_buffinit(L, &B);
    Tcl_ExternalToUtf(S->interp, enc, s, len, 0, NULL,
            luaL_prepbuffsize(&B, len*4), len*4, NULL, NULL, 
            &reslen);
    luaL_addsize(&B, reslen);
    luaL_pushresult(&B);
#endif
    return 1;
}

static int Ltcl_toutf8(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    size_t len;
    const char *d, *s = luaL_checklstring(L, 2, &len);
    Tcl_Encoding enc = ltcl_checkencoding(L, S, 3);
    Tcl_DString dst;
    d = Tcl_UtfToExternalDString(enc, s, len, &dst);
    lua_pushlstring(L, d, Tcl_DStringLength(&dst));
    Tcl_DStringFree(&dst);
    return 1;
}

static int Ltcl_concat(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    int i, top = lua_gettop(L);
    ltcl_Buffer B;
    ltcl_buffinit(L, &B);
    for (i = 1; i <= top; ++i)
        ltcl_addobject(&B, ltcl_checkobject(L, i));
    ltcl_newobject(L, S, Tcl_ConcatObj(B.argc, B.argv));
    ltcl_freeobjects(&B);
    return 1;
}

static int Ltcl_eval(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    int i, top = lua_gettop(L);
    Tcl_Obj *list;
    ltcl_Buffer B;
    if (top == 2) {
        size_t len;
        const char *s = luaL_checklstring(L, 2, &len);
        return ltcl_pushresult(L, S, Tcl_EvalEx(S->interp, s, len, 0));
    }
    ltcl_buffinit(L, &B);
    for (i = 2; i <= top; ++i)
        ltcl_addobject(&B, ltcl_checkobject(L, i));
    list = Tcl_ConcatObj(B.argc, B.argv);
    ltcl_freeobjects(&B);
    return ltcl_pushresult(L, S, Tcl_EvalObjEx(S->interp, list, 0));
}

static int Ltcl_call(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    int res, i, top = lua_gettop(L);
    ltcl_Buffer B;
    ltcl_buffinit(L, &B);
    for (i = 2; i <= top; ++i)
        ltcl_addobject(&B, ltcl_checkobject(L, i));
    res = ltcl_pushresult(L, S,
            Tcl_EvalObjv(S->interp, B.argc, B.argv, 0));
    ltcl_freeobjects(&B);
    return res;
}

static int Ltcl_calltable(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    int res, i, top = lua_gettop(L);
    ltcl_Buffer B;
    luaL_checktype(L, top, LUA_TTABLE);
    ltcl_buffinit(L, &B);
    for (i = 2; i < top; ++i)
        ltcl_addobject(&B, ltcl_checkobject(L, i));
    ltcl_addarraypart(&B, top);
    res = ltcl_pushresult(L, S,
            Tcl_EvalObjv(S->interp, B.argc, B.argv, 0));
    ltcl_freeobjects(&B);
    return res;
}

static int Ltcl_calloption(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    int i, top = lua_gettop(L), res;
    ltcl_Buffer B;
    luaL_checkstring(L, 2);
    luaL_checktype(L, top, LUA_TTABLE);
    ltcl_buffinit(L, &B);
    for (i = 2; i < top; ++i)
        ltcl_addobject(&B, ltcl_checkobject(L, i));
    ltcl_addarraypart(&B, top);
    ltcl_addhashpart(&B, top);
    res = ltcl_pushresult(L, S,
            Tcl_EvalObjv(S->interp, B.argc, B.argv, 0));
    ltcl_freeobjects(&B);
    return res;
}

static int Ltcl_index(lua_State *L) {
    ltcl_State *S;
    const char *name;
    Tcl_Obj *obj;
    if (lua_getmetatable(L, 1)) {
        lua_pushvalue(L, 2);
        if (lua53_rawget(L, -2) != LUA_TNIL)
            return 1;
    }
    S = ltcl_checkstate(L, 1);
    name = luaL_checkstring(L, 2);
    obj = Tcl_GetVar2Ex(S->interp, name, NULL, TCL_GLOBAL_ONLY);
    if (obj == NULL) return 0;
    return ltcl_pushobject(L, S, obj);
}

static int Ltcl_newindex(lua_State *L) {
    ltcl_State *S = ltcl_checkstate(L, 1);
    const char *key = luaL_checkstring(L, 2);
    Tcl_Obj *value = NULL;
    int success;
    if (!lua_isnoneornil(L, 3))
        value = ltcl_checkobject(L, 3);
    if (value == NULL)
        success = Tcl_UnsetVar(S->interp, key,
                TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == TCL_OK;
    else
        success = Tcl_SetVar2Ex(S->interp, key, NULL, value,
                TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != NULL;
    if (!success) return luaL_error(L, Tcl_GetStringResult(S->interp));
    return 0;
}

LUALIB_API int luaopen_tcl(lua_State *L) {
    luaL_Reg libs[] = {
        { "__gc",       Ltcl_delete   },
        { "__tostring", Ltcl_tostring },
        { "__call",     Ltcl_eval     },
        { "__index",    Ltcl_index    },
        { "__newindex", Ltcl_newindex },
#define ENTRY(name) { #name, Ltcl_##name }
        ENTRY(new),
        ENTRY(delete),
        ENTRY(object),
        ENTRY(concat),
        ENTRY(proc),
        ENTRY(set),
        ENTRY(get),
        ENTRY(unset),
        ENTRY(trace),
        ENTRY(untrace),
        ENTRY(call),
        ENTRY(calltable),
        ENTRY(calloption),
        ENTRY(encoding),
        ENTRY(toutf8),
        ENTRY(fromutf8),
#undef  ENTRY
        { NULL, NULL }
    };
    open_object(L);
    if (luaL_newmetatable(L, LTCL_INTERP)) {
        int major, minor;
        luaL_setfuncs(L, libs, 0);
        Tcl_GetVersion(&major, &minor, NULL, NULL);
        lua_pushfstring(L, "%d.%d", major, minor);
        lua_setfield(L, -2, "version");
    }
    return 1;
}


/* tcl extension routines */

static Tcl_Obj *ltcl_NewLuaObj(lua_State *L) {
    Tcl_Obj *obj = Tcl_NewObj();
    obj->bytes = NULL;
    obj->typePtr = &ltcl_LuaObjectType;
    obj->internalRep.ptrAndLongRep.ptr = (void*)L;
    obj->internalRep.ptrAndLongRep.value =
        (unsigned long)luaL_ref(L, LUA_REGISTRYINDEX);
    return obj;
}

static void ltcl_FreeLuaObjIntRep(Tcl_Obj *obj) {
    lua_State *L = (lua_State*)obj->internalRep.ptrAndLongRep.ptr;
    int ref = (int)obj->internalRep.ptrAndLongRep.value;
    luaL_unref(L, LUA_REGISTRYINDEX, ref);
}

static void ltcl_DupLuaObjIntRep(Tcl_Obj *src, Tcl_Obj *dup) {
    lua_State *L = (lua_State*)src->internalRep.ptrAndLongRep.ptr;
    int ref = (int)src->internalRep.ptrAndLongRep.value;
    dup->typePtr = &ltcl_LuaObjectType;
    dup->internalRep.ptrAndLongRep.ptr = (void*)L;
    dup->internalRep.ptrAndLongRep.value = (unsigned long)ref;
}

static void ltcl_UpdateStringOfLuaObj(Tcl_Obj *obj) {
    lua_State *L = (lua_State*)obj->internalRep.ptrAndLongRep.ptr;
    int len, ref = (int)obj->internalRep.ptrAndLongRep.value;
    char buff[32 + sizeof(void*)*2];
    lua_rawgeti(L, LUA_REGISTRYINDEX, ref);
    len = sprintf("%s:%p", luaL_typename(L, -1), lua_topointer(L, -1));
    obj->bytes = (char*)ckalloc(len + 1);
    memcpy(obj->bytes, buff, len+1);
    obj->length = len;
    lua_pop(L, 2);
}

static const Tcl_ObjType ltcl_LuaObjectType = {
    "luaObject",
    ltcl_FreeLuaObjIntRep,
    ltcl_DupLuaObjIntRep,
    ltcl_UpdateStringOfLuaObj,
    NULL,
};

static void ltcl_FreeLuaState(ClientData cdata, Tcl_Interp *interp) {
    lua_State *L = (lua_State*)L;
    lua_close(L);
}

static int ltcl_luaCmd(ClientData cdata, Tcl_Interp *interp, int argc, Tcl_Obj *const*argv) {
    ltcl_State *S = (ltcl_State*)cdata;
    lua_State *L = S->L;
    int res, len, i, top = lua_gettop(L);
    if (argc < 2) {
        Tcl_WrongNumArgs(interp, 1, argv, "string/luaObject ?arg...?");
        return TCL_ERROR;
    }
    luaL_checkstack(L, argc+3, "Too many proc arguments");
    lua_getglobal(L, "tcl"); /* 1 */
    if (ltcl_retrieve(S)) /* 2 */
        lua_setglobal(L, "tcl"); /* 2->tcl */
    lua_pushcfunction(L, ltcl_traceback); /* 2 */
    if (argv[1]->typePtr == &ltcl_LuaObjectType) {
        lua_rawgeti(L, LUA_REGISTRYINDEX,
                (int)argv[1]->internalRep.ptrAndLongRep.value); /* 3 */
    }
    else {
        const char *s = Tcl_GetStringFromObj(argv[1], &len);
        if (luaL_loadbuffer(L, s, len, "=[Lua chunk]") != LUA_OK) { /* 3 */
            Tcl_SetResult(interp, (char*)lua_tostring(L, -1), TCL_VOLATILE);
            lua_settop(L, top);
            return TCL_ERROR;
        }
    }
    for (i = 2; i < argc; ++i) /* 4 ~ argc-2 */
        ltcl_pushobject(L, S, argv[i]);
    res = lua_pcall(L, argc-2, 1, top+2);
    Tcl_SetObjResult(interp, ltcl_testobject(L, -1));
    lua_settop(L, top + 1);
    lua_setglobal(L, "tcl");
    return res == LUA_OK ? TCL_OK : TCL_ERROR;
}

static int ltcl_luaprocCmd(ClientData cdata, Tcl_Interp *interp, int argc, Tcl_Obj *const*argv) {
    lua_State *L = ((ltcl_State*)cdata)->L;
    int len; const char *s;
    Tcl_Obj *obj;
    if (argc < 2) {
        Tcl_WrongNumArgs(interp, 1, argv, "arg ?arg...?");
        return TCL_ERROR;
    }
    obj = Tcl_ConcatObj(argc-1, argv+1);
    luaL_checkstack(L, 2, "Too many luaproc arguments");
    s = Tcl_GetStringFromObj(obj, &len);
    if (luaL_loadbuffer(L, s, len, "=[Lua chunk]") != LUA_OK) { /* 3 */
        Tcl_SetResult(interp, (char*)lua_tostring(L, -1), TCL_VOLATILE);
        lua_pop(L, 1);
        return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, ltcl_toprimitive(L, -1, LUA_TFUNCTION));
    lua_pop(L, 1);
    return TCL_OK;
}

int DLLEXPORT Lua_Init(Tcl_Interp *interp) {
    lua_State *L;
    if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL
            || Tcl_PkgProvide(interp, "lua", "1.0") == TCL_ERROR)
        return TCL_ERROR;

    L = luaL_newstate();
    luaL_openlibs(L);
    luaL_requiref(L, "tcl", luaopen_tcl, 0);
    ltcl_newstate(L, interp);

    Tcl_SetAssocData(interp, "lua_State", ltcl_FreeLuaState, L);
    return TCL_OK;
}

/* cc: flags+='-s -O3 -mdll -DLUA_BUILD_AS_DLL'
 * cc: libs+='-llua53 -ltcl86' output='tcl.dll' */