# Tcl bindings for LuaJIT and Lua 5.1-5.3.
# This module requires a recent version of Critcl, pkg-config and a LuaJIT 2.x
# or a Lua 5.1-5.3 development package for your OS.
# Copyright (c) 2017 dbohdan.
# License: MIT.
package require critcl 3.1.11

if {![::critcl::compiling]} {
    error {critcl found no compiler}
}

namespace eval ::luajit {
    variable bindingsVersion 0.1.1
    # Set the variable ::luajit::luaPackage in your code (set or
    # ::luajit::luaHeaders and ::luajit::luaLib directly) before sourcing or
    # requiring this module to use a different version of Lua.
    if {![info exists luaPackage]} {
        # The default Lua package.

        # variable luaPackage lua5.1
        # variable luaPackage lua5.2
        # variable luaPackage lua5.3
        variable luaPackage luajit
    }
    if {![info exists luaHeaders]} {
        variable luaHeaders [exec pkg-config --cflags $luaPackage]
    }
    if {![info exists luaLib]} {
        variable luaLib [exec pkg-config --libs $luaPackage]
    }
}

critcl::cheaders $::luajit::luaHeaders
critcl::clibraries $::luajit::luaLib
critcl::ccode {
    #include <lua.h>
    #include <lauxlib.h>
    #include <lualib.h>
    #define LUAJIT_CDATA ((lua_State *) cdata)
}

critcl::cinit {
    lua_State *L = luaL_newstate();
    luaL_openlibs(L);
} {}

critcl::ccommand luajit::eval {cdata interp objc objv} {
    size_t len;
    int rc;
    const char *lua_res;

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "code");
        return TCL_ERROR;
    }

    rc = luaL_loadstring(LUAJIT_CDATA, Tcl_GetStringFromObj(objv[1], NULL)) ||
         lua_pcall(LUAJIT_CDATA, 0, 1, 0);
    lua_res = lua_tolstring(LUAJIT_CDATA, -1, &len);
    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(lua_res, len));
    lua_pop(LUAJIT_CDATA, 1);

    if (rc == 0) {
        return TCL_OK;
    } else {
        return TCL_ERROR;
    }
} -clientdata L

critcl::ccode {
    Tcl_Obj* table2tcl(ClientData cdata, Tcl_Interp *interp,
                       lua_State *L, int index) {
        Tcl_Obj* result = Tcl_NewListObj(0, NULL);
        lua_pushnil(L);
        index--;

        while (lua_next(L, index) != 0) {
            Tcl_Obj* kv[2];
            int i;
            for (i = 0; i < 2; i++) {
                int kv_index = -2 + i;
                if (lua_istable(L, kv_index)) {
                    kv[i] = table2tcl(cdata, interp, L, kv_index);
                    if (kv[i] == NULL) {
                        return NULL;
                    }
                } else {
                    /* Can't call lua_tolstring() unconditionally because it
                       changes the internal representation of the value. It
                       will throw off lua_next() if a value that was a number
                       becomes a string. */
                    if (lua_isnumber(LUAJIT_CDATA, kv_index)) {
                        kv[i] = Tcl_NewWideIntObj(
                            lua_tonumber(LUAJIT_CDATA, kv_index)
                        );
                    } else {
                        size_t lua_str_len;
                        const char* lua_str = lua_tolstring(LUAJIT_CDATA,
                                                            kv_index,
                                                            &lua_str_len);
                        kv[i] = Tcl_NewByteArrayObj(lua_str, lua_str_len);            
                    }
                }
                if (Tcl_ListObjAppendElement(interp, result, kv[i]) != TCL_OK) {
                    return NULL;
                }
            }
            lua_pop(L, 1);
        }
        return result;
    }
}

critcl::ccommand luajit::call {cdata interp objc objv} {
    int err;
    int i;
    int len;
    int level = lua_gettop(LUAJIT_CDATA);
    int nresults = -1;
    int listc;
    Tcl_Obj **listv;
    Tcl_Obj *results;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "funcpath ?arg ...?");
        return TCL_ERROR;
    }

    /* Traverse tables to find the function to call. */
    if (Tcl_ListObjGetElements(interp, objv[1], &listc, &listv) != TCL_OK) {
        Tcl_SetObjResult(
            interp,
            Tcl_NewStringObj("can't process function path list", -1)
        );
        return TCL_ERROR;
    }
    if (listc == 0) {
        Tcl_SetObjResult(
            interp,
            Tcl_NewStringObj("function path can't be empty", -1)
        );
        return TCL_ERROR;
    }
    lua_getglobal(LUAJIT_CDATA, Tcl_GetStringFromObj(listv[0], NULL));
    if (lua_isnil(LUAJIT_CDATA, -1)) {
        Tcl_SetObjResult(
            interp,
            Tcl_NewStringObj("global Lua variable not found", -1)
        );
        lua_pop(LUAJIT_CDATA, 1);
        return TCL_ERROR;
    }
    for (i = 1; i < listc; i++) {
        lua_getfield(LUAJIT_CDATA, -1, Tcl_GetStringFromObj(listv[i], NULL));
        lua_remove(LUAJIT_CDATA, -2);
    }
    if (lua_isnil(LUAJIT_CDATA, -1)) {
        Tcl_SetObjResult(
            interp,
            Tcl_NewStringObj("Lua function not found", -1)
        );
        lua_pop(LUAJIT_CDATA, 1);
        return TCL_ERROR;
    }

    /* Push the arguments. */
    for (i = 2; i < objc; i++) {
        char* arg = Tcl_GetByteArrayFromObj(objv[i], &len);
        lua_pushlstring(LUAJIT_CDATA, arg, len);
    }

    /* Call the function. */
    err = lua_pcall(LUAJIT_CDATA, objc - 2, LUA_MULTRET, 0);
    nresults = lua_gettop(LUAJIT_CDATA) - level;

    /* Process multiple return values. */
    results = Tcl_NewListObj(0, NULL);
    for (i = nresults - 1; i >= 0; i--) {
        Tcl_Obj *elem = NULL;
        int index = -1 - i;
        if (lua_istable(LUAJIT_CDATA, index)) {
            elem = table2tcl(cdata, interp, LUAJIT_CDATA, index);
            if (elem == NULL) {
                Tcl_SetObjResult(
                    interp,
                    Tcl_NewStringObj("can't convert Lua table to list", -1)
                );
                err = 1;
                break;
            }
        } else {
            size_t lua_str_len;
            const char* lua_str = lua_tolstring(LUAJIT_CDATA, index,
                                                &lua_str_len);
            elem = Tcl_NewByteArrayObj(lua_str, lua_str_len);
        }
        if (Tcl_ListObjAppendElement(interp, results, elem) != TCL_OK) {
            Tcl_SetObjResult(
                interp,
                Tcl_NewStringObj("can't create result list", -1)
            );
            err = 1;
            break;
        }
    }
    if (nresults == 1) {
        Tcl_Obj* result;
        Tcl_ListObjIndex(interp, results, 0, &result);
        Tcl_SetObjResult(interp, result);
    } else {
        Tcl_SetObjResult(interp, results);
    }

    lua_pop(LUAJIT_CDATA, nresults);

    if (err) {
        return TCL_ERROR;
    } else {
        return TCL_OK;
    }
} -clientdata L

proc ::luajit::safe-name {text} {
    string trim [regsub -all {[^[:alnum:]]+} $text _] _
}

proc ::luajit::ljproc {name arglist body} {
    set luaName [safe-name $name]
    set luaArgs {}
    set procBody "luajit::call $luaName"
    foreach arg $arglist {
        if {$arg eq {args}} {
            append procBody " {*}\$args"
            lappend luaArgs ...
        } else {
            append procBody " \$$arg"
            lappend luaArgs $arg
        }
    }
    ::luajit::eval "function ${luaName}([join $luaArgs ,])\n$body\nend"
    proc $name $arglist $procBody
}

proc ::luajit::assert-is-one-of {actual args} {
    set matched 0
    foreach expected $args {
        if {$actual eq $expected} {
            set matched 1
            break
        }
    }
    if {!$matched} {
        if {[string length $actual] > 200} {
            set actual [string range $actual 0 199]...
        }
        error "expected \"[join $args {" or "}]\",\n\
               but got \"$actual\""
    }
}

proc ::luajit::assert-equal {actual expected} {
    ::luajit::assert-is-one-of $actual $expected
}

proc ::luajit::dict-sort d {
    set res {}
    foreach key [lsort [dict keys $d]] {
        set value [dict get $d $key]
        if {[llength $key] % 2 == 0} {
            set key [dict-sort $key]
        }
        if {[llength $value] % 2 == 0} {
            set value [dict-sort $value]
        }
        lappend res $key $value
    }
    return $res
}

proc ::luajit::test {} {
    if [catch {luajit::eval {
        print("using " .. jit.version)
    }}] {
        luajit::eval {
            print("using " .. _VERSION)
        }
    }

    assert-equal [luajit::call {string find} abcdef cd] {3 4}

    catch {luajit::call {} abcdef cd} err
    assert-equal $err {function path can't be empty}

    catch {luajit::call {nope bogus} foo} err
    assert-equal $err {global Lua variable not found}

    catch {luajit::call {math bogus} foo} err
    assert-equal $err {Lua function not found}


    luajit::ljproc add {a b} {
        return a + b
    }
    assert-is-one-of [luajit::call add 5 7] 12 12.0
    assert-is-one-of [add 5 7] 12 12.0

    luajit::ljproc divmul {a b} {
        return math.floor(a / b), a % b, a, b
    }
    assert-is-one-of [luajit::call divmul 7 3] {2 1 7 3} {2 1.0 7 3}
    assert-is-one-of [divmul 7 3] {2 1 7 3} {2 1.0 7 3}

    luajit::ljproc varargs {a b c args} {
        return a, b, c, {...}
    }
    assert-equal [luajit::call varargs foo bar baz a b c] \
                 {foo bar baz {1 a 2 b 3 c}}
    assert-equal [varargs foo bar baz a b c] {foo bar baz {1 a 2 b 3 c}}

    catch {luajit::ljproc foo {} {blah}} err
    assert-is-one-of $err \
                     {[string "function foo()..."]:3: '=' expected near 'end'} \
                     {[string "function foo()..."]:3: syntax error near 'end'}

    luajit::ljproc bar {} {return nope['bogus']}
    catch bar err
    assert-is-one-of $err \
                     {[string "function bar()..."]:2: attempt to index global\
                      'nope' (a nil value)} \
                     {[string "function bar()..."]:2: attempt to index a nil\
                      value (global 'nope')}

    luajit::ljproc table-1 {} {
        return 1, {a = 1, b = 2, c = 3}, 3, 4, 5
    }
    set res [table-1]
    lset res 1 [luajit::dict-sort [lindex $res 1]]
    assert-equal $res {1 {a 1 b 2 c 3} 3 4 5}
    unset res

    luajit::ljproc table-2 {} {
        return {}
    }
    assert-equal [table-2] {}

    luajit::ljproc table-3 {} {
        return {2, 3, 4}
    }
    assert-equal [luajit::dict-sort [table-3]] {1 2 2 3 3 4}

    luajit::ljproc nested-table-1 {} {
        return {a = 1, b = 2, c = {3, 4, 5}, d = {e = 6, f = 7}}
    }
    assert-equal [luajit::dict-sort [nested-table-1]] \
                 {a 1 b 2 c {1 3 2 4 3 5} d {e 6 f 7}}

    luajit::ljproc nested-table-2 {} {
        local t1 = {a = 1, b = 2}
        local t2 = {hello = {-3, -2, -1}}
        t2[t1] = {0, 1, 2}
        return t2
    }
    assert-equal [luajit::dict-sort [nested-table-2]] \
                 {{a 1 b 2} {1 0 2 1 3 2} hello {1 -3 2 -2 3 -1}}


    # Benchmark.
    set s {}
    set refValue 0
    for {set i 0} {$i < 1024*1014} {incr i} {
        incr refValue [expr {$i % 256}]
        append s [format %c [expr {$i % 256}]]
    }
    proc char-sum-1 data {
        set sum 0
        set len [string length $data]
        for {set i 0} {$i < $len} {incr i} {
            binary scan $data "@$i cu" byte
            incr sum $byte
        }
        return $sum
    }
    proc char-sum-2 data {
        set sum 0
        foreach c [split $data {}] {
            scan $c %c byte
            incr sum $byte
        }
        return $sum
    }
    luajit::ljproc lj-sum data {
        local sum = 0
        for i = 1, #data do
            sum = sum + data:byte(i, i)
        end
        return sum
    }
    assert-equal [char-sum-1 $s] $refValue
    assert-equal [char-sum-2 $s] $refValue
    assert-equal [lj-sum $s] $refValue
    puts [time {char-sum-1 $s} 5]
    puts [time {char-sum-2 $s} 5]
    puts [time {lj-sum $s} 5]
    puts [time {::luajit::call lj_sum $s} 5]
}

# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    ::luajit::test
}

using LuaJIT 2.0.4
798469.2 microseconds per iteration
682693.4 microseconds per iteration
2614.4 microseconds per iteration
2527.8 microseconds per iteration

#! /usr/bin/env luajit

ffi = require("ffi")
-- The following line is for openSUSE Tumbleweed. If you run a different OS
-- you should probably replace it with something like
-- local tcl = ffi.load("tcl8.6")
local tcl = ffi.load("/usr/lib64/libtcl8.6.so")
ffi.cdef[[
typedef struct Tcl_Interp Tcl_Interp;
typedef struct Tcl_Obj Tcl_Obj;
typedef struct Tcl_DString {
    char *string;
    int length;
    int spaceAvl;
    char staticSpace[200];
} Tcl_DString;

Tcl_Obj *        Tcl_NewStringObj(const char *bytes, int length);
Tcl_Interp *     Tcl_CreateInterp(void);
char *           Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
int              Tcl_InterpDeleted(Tcl_Interp *interp);
char *           Tcl_GetString(Tcl_Obj *objPtr);
int              Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags);
]]

local interp = tcl.Tcl_CreateInterp()
local script = tcl.Tcl_NewStringObj("puts [pwd]", -1)
tcl.Tcl_EvalObjEx(interp, script, 0)

local pwd = ffi.new("Tcl_DString")
tcl.Tcl_GetCwd(interp, pwd)
print(ffi.string(pwd.string))