Lua.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#ifdef PERL_UNUSED_DECL
#   undef PERL_UNUSED_DECL
#endif

#include "ppport.h"

#include "const-c.inc"

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

/* Support Lua 5.2 */
#if LUA_VERSION_NUM >= 502
#define lua_strlen(L,i) lua_rawlen(L, (i))
#endif

SV *UNDEF, *LuaNil, NIL;
AV *INLINE_RETURN;

/* Called when Lua >= 5.2 closes a Perl filehandle - We don't currently
 * do anything with this.  So we end up leaking :stdio layers (as we
 * also do with 5.1).
 */
static int close_attempt(lua_State *L) { return 0; }


void push_ary	    (lua_State *, AV*);
void push_hash	    (lua_State *, HV*);
void push_val	    (lua_State *, SV*);
void push_func	    (lua_State *, CV*);

SV* bool_ref	    (lua_State *, int);
SV* table_ref	    (lua_State *, int);
SV* func_ref	    (lua_State *L);
SV* user_data	    (lua_State *L);
SV* luaval_to_perl  (lua_State *, int, int*);

static lua_State *INTERPRETER = NULL;

int
is_lua_nil (SV* val) {
    if (sv_isobject(val) && SvIV(SvRV(val)) == (IV)&PL_sv_undef &&
	strEQ(HvNAME(SvSTASH(SvRV(val))), "Inline::Lua::Nil"))
	return 1;
    return 0;
}

/* Non-destructively translate a a number to a string.
 * lua_tostring() can't be used as it turns the value
 * on the stack into a string. */
char *
num2string (lua_Number n, I32 *klen) {
    char s[32];
    char *str;
    STRLEN len;
    sprintf(s, LUA_NUMBER_FMT, n);
    *klen = strlen(s);
    len = *klen + 1;
    New(0, str, len, char);
    Copy(s, str, len, char);
    return str;
}

/* The C-closure responsible for calling Perl functions
 * that were passed to Lua functions by reference.
 * The codereference is passed as lightuserdata and
 * always resides at lua_upvalueindex(1) */
int
trigger_cv (lua_State *L) {
    dSP;
    register int i;
    int dopop;
    int nargs = lua_gettop(L);
    int nresults;

    CV *cv = (CV*)lua_touserdata(L, lua_upvalueindex(1));
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

    for (i = 1; i <= nargs; i++) {
	SV *sv = luaval_to_perl(L, i, &dopop);
	XPUSHs(sv_2mortal(sv));
    }
    lua_settop(L, 0);
    PUTBACK;

    nresults = call_sv((SV*)cv, G_ARRAY);

    SPAGAIN;

    /* again the reversed order of values
     * in the Lua stack bites, so we
     * cannot use POPs here */
    for (i = 0; i < nresults; i++) {
	int offset = nresults - i - 1;
	SV *val = *(sp - offset);
	push_val(L, val);
    }
    /* pop all in one go */
    sp -= nresults;

    PUTBACK;
    FREETMPS;
    LEAVE;

    return nresults;
}

/* The callback used by lua_dump to serialize the
 * bytecode */
int
dumper (lua_State *L, const void *p, size_t size, void *f) {
    fwrite(p, size, 1, (FILE*)f);
    return 0;
}

/* push a Perl array onto the Lua stack */
void
push_ary (lua_State *L, AV *av) {
    register int i;
    lua_newtable(L);

    for (i = 0; i <= av_len(av); i++) {
	SV **ptr = av_fetch(av, i, FALSE);
#if LUA_VERSION_NUM < 503
	lua_pushnumber(L, (lua_Number)i+1);
#else
	lua_pushinteger(L, (lua_Integer)i+1);
#endif
	if (ptr)
	    push_val(L, *ptr);
	else
	    lua_pushnil(L);
	lua_settable(L, -3);
    }
}

/* push a Perl hash onto the Lua stack */
void
push_hash (lua_State *L, HV *hv) {
    register HE* he;

    lua_newtable(L);
    hv_iterinit(hv);

    while (he = hv_iternext(hv)) {
	I32 len;
	char *key;
	key = hv_iterkey(he, &len);
	lua_pushlstring(L, key, len);
	push_val(L, hv_iterval(hv, he));
	lua_settable(L, -3);
    }
}

/* push a Perl function reference onto the Lua stack */
void
push_func (lua_State *L, CV *cv) {
    lua_pushlightuserdata(L, cv);
    lua_pushcclosure(L, trigger_cv, 1);
}

/* turn the Perl glob-reference into a FILE* and push it
 * along with the appropriate metatable onto the Lua stack */
void
push_io (lua_State *L, PerlIO *pio) {
#if LUA_VERSION_NUM < 502
    FILE **fp = (FILE**)lua_newuserdata(L, sizeof(FILE*));
    *fp = PerlIO_exportFILE(pio, NULL);
    luaL_getmetatable(L, "FILE*");
    lua_setmetatable(L, -2);
#else
    // Lua 5.2+
    // We need a close function or Lua thinks the file handle is closed
    luaL_Stream *p = (luaL_Stream *)lua_newuserdata(L, sizeof(luaL_Stream));
    p->f = PerlIO_exportFILE(pio, NULL);
    p->closef = &close_attempt;
    luaL_setmetatable(L, LUA_FILEHANDLE);
#endif
}


/* push a generic reference into the Lua stack:
 * calls one of push_(ary|hash|func|io) */
void
push_ref (lua_State *L, SV *val) {

    switch (SvTYPE(SvRV(val))) {
	case SVt_PVAV:
	    push_ary(L, (AV*)SvRV(val));
	    return;
	case SVt_PVHV:
	    push_hash(L, (HV*)SvRV(val));
	    return;
	case SVt_PVCV:
	    push_func(L, (CV*)SvRV(val));
	    return;
	case SVt_PVGV:
	    push_io(L, IoIFP(sv_2io(SvRV(val))));
	    return;
	default:
	    if (sv_derived_from(val, "Inline::Lua::Boolean")) {
	        lua_pushboolean(L, !!SvIV(SvRV(val)));
	        return;
	    } else {
	        croak("Attempt to pass unsupported reference type (%s) to Lua", sv_reftype(SvRV(val), 0));
	    }
    }
}

/* push a Perl value onto the Lua stack:
 * does the right thing for any Perl type
 * handled by Inline::Lua */
void
push_val (lua_State *L, SV *val) {

    if (is_lua_nil(val)) {
	lua_pushnil(L);
	return;
    }

    if (!val || val == &PL_sv_undef || !SvOK(val)) {
	if (!UNDEF || UNDEF == &PL_sv_undef || !SvOK(UNDEF))
	    lua_pushnil(L);
	else
	    /* otherwise we can safely call push_val again
	     * because Inline::Lua::_undef is defined */
	    push_val(L, UNDEF);
	return;
    }

    switch (SvTYPE(val)) {
	case SVt_IV:
            if(SvROK(val)) {
                push_ref(L, val);
            } else {
#if LUA_VERSION_NUM < 503
                lua_pushnumber(L, (lua_Number)SvIV(val));
#else
                lua_pushinteger(L, (lua_Integer)SvIV(val));
#endif
            }
	    return;
	case SVt_NV:
	    lua_pushnumber(L, (lua_Number)SvNV(val));
	    return;
	case SVt_PV: case SVt_PVIV:
	case SVt_PVNV: case SVt_PVMG:
	    {
		STRLEN n_a;
		char *cval = SvPV(val, n_a);
		lua_pushlstring(L, cval, n_a);
		return;
	    }
    }
}

/* Turns a Lua type into a Perl type and returns it.
 * 'dopop' is set to 1 if the caller has to do a lua_pop.
 * The only case where this does not happen is if the value
 * is a LUA_TFUNCTION (luaL_ref() already pops it off). */
SV*
luaval_to_perl (lua_State *L, int idx, int *dopop) {
    *dopop = 1;
    switch (lua_type(L, idx)) {
	case LUA_TNIL:
	    return &PL_sv_undef;
	case LUA_TBOOLEAN:
	    return bool_ref(L, lua_toboolean(L, idx));
	case LUA_TNUMBER:
	    return newSVnv(lua_tonumber(L, idx));
	case LUA_TSTRING:
	    return newSVpvn(lua_tostring(L, idx), lua_strlen(L, idx));
	case LUA_TTABLE:
	    return table_ref(L, idx);
	case LUA_TFUNCTION:
	    *dopop = 0;
	    return func_ref(L);
	default:
	    abort();
    }
}

/* Handles the return values of a complete Lua script
 * upon compilation. Return values are converted into
 * Perl types, unshifted into INLINE_RETURN and popped
 * off the Lua stack */
AV*
lua_main_return (lua_State *L, int idx, int num) {
    register int i;
    int nargs = idx - num + 1;

    for (i = 0; i < nargs; i++) {
	int top = idx-i;
	av_unshift(INLINE_RETURN, 1);
	switch (lua_type(L, top)) {
	    case LUA_TNIL:
		av_store(INLINE_RETURN, 0, &PL_sv_undef);
	    case LUA_TBOOLEAN:
		    av_store(INLINE_RETURN, 0, bool_ref(L, lua_toboolean(L, top)));
		    break;
	    case LUA_TNUMBER:
		    av_store(INLINE_RETURN, 0, newSVnv(lua_tonumber(L, top)));
		    break;
	    case LUA_TSTRING:
		    av_store(INLINE_RETURN, 0, newSVpvn(lua_tostring(L, top), lua_strlen(L, top)));
		    break;
	    case LUA_TTABLE:
		    av_store(INLINE_RETURN, 0, table_ref(L, top));
		    break;
	    case LUA_TFUNCTION:
		    av_store(INLINE_RETURN, 0, func_ref(L));
		    break;
	    case LUA_TUSERDATA:
		    av_store(INLINE_RETURN, 0, user_data(L));
		    break;
	    default:
		    croak("Attempt to return unsupported Lua type (%s)", lua_typename(L, lua_type(L, idx)));
	}
    }
    return INLINE_RETURN;
}

/* Lua tables are both an array and a hash but this can't be known in advance.
 * Initially it is assumed that the Lua table can be turned into a plain Perl
 * array. However, once a stringy key is found the strategy has to be switched
 * and the array populated so far is converted into a hash */
HV *
ary_to_hash (AV *ary) {
    register int i;
    int len = av_len(ary);
    HV *hv = newHV();
    SV *key = newSViv(0);
    for (i = 0; i <= len; i++) {
	if (!av_exists(ary, i))
	    continue;
	sv_setiv(key, i+1);	/* +1 because Lua tables start at 1 */
	hv_store_ent(hv, key, *av_fetch(ary, i, FALSE), 0);
    }
    SvREFCNT_dec(key);
    return hv;
}

/* Adds a key/value pair from a Lua table to 'any'.
 * 'any' is a pointer to either an AV* or HV*. When it was
 * an array and the current key is a string, 'isary' is set
 * to false and the array transformed into a hash */
int
add_pair (lua_State *L, SV **any, int *isary) {
#define KEY -2
#define VAL -1
    int dopop;

    if (*isary && lua_type(L, KEY) != LUA_TNUMBER) {
	HV *tbl = ary_to_hash((AV*)*any);
	*isary = 0;
	*any = (SV*)tbl;
    }

    if (*isary) {
	int idx = lua_tonumber(L, KEY);
	SV *val = luaval_to_perl(L, lua_gettop(L), &dopop);
	SvREFCNT_inc(val);
	if (!av_store((AV*)*any, idx-1, val))
	    SvREFCNT_dec(val);
    }
    else {
	const char *key;
	I32 klen;
	SV *val;
	int free = 0;
	switch (lua_type(L, KEY)) {
	    case LUA_TNUMBER:
		{
		lua_Number n = lua_tonumber(L, KEY);
		key = (const char*)num2string(n, &klen);
		free = 1;
		break;
		}
	    case LUA_TSTRING:
		key = lua_tostring(L, KEY);
		klen = lua_strlen(L, KEY);
		break;
	    default:
		croak("Illegal type (%s) in table subscript", lua_typename(L, lua_type(L, KEY)));
	}
	val = luaval_to_perl(L, lua_gettop(L), &dopop);
	SvREFCNT_inc(val);
	if (!hv_store((HV*)*any, key, klen, val, 0))
	    SvREFCNT_dec(val);
	if (free)
	    Safefree(key);
    }

    return dopop;
}

/* Return our Inline::Lua::Boolean datatype.
 *
 * TODO: Try to do this only once (or twice), and return the same TRUE or
 * FALSE reference subsequently. */
SV*
bool_ref (lua_State *L, int b) {
    SV *sv;

    if (b) {
        sv = eval_pv("Inline::Lua::Boolean::TRUE", 1);
    } else {
        sv = eval_pv("Inline::Lua::Boolean::FALSE", 1);
    }

    return SvREFCNT_inc(sv);
}

/* The Lua table being in the stack at 'idx' is turned into a
 * Perl AV _or_ HV (depending on whether the lua table has a stringy
 * key in it and a reference to that is returned */
SV*
table_ref (lua_State *L, int idx) {
    int isary = 1;	/* initially we always assume it's an array */
    AV *tbl = newAV();

    assert(idx >= 1);

    lua_pushnil(L);
    while (lua_next(L, idx) != 0) {
	if (add_pair(L, (SV**)&tbl,  &isary))
	    lua_pop(L, 1);
    }
    return newRV_noinc((SV*)tbl);
}

/* When a Lua function returns a function to perl, a reference
 * to this function is put into LUA_REGISTRY. Here we call
 * 'create_func_ref' which returns a Perl closure which does
 *	sub { $lua->call( $func, -1, @_ ) }
 * Calling this closure would then trigger the Lua function. */
SV*
func_ref (lua_State *L) {
    dSP;

    SV *lua = sv_newmortal();
    SV *func = newSViv(luaL_ref(L, LUA_REGISTRYINDEX));
    SV *funcref;

    sv_setref_pv(lua, "Inline::Lua", (void*)L);

    ENTER;
    PUSHMARK(SP);
    XPUSHs(lua);		/* $lua */
    XPUSHs(sv_2mortal(func));	/* $func */
    PUTBACK;

    call_pv("Inline::Lua::create_func_ref", G_SCALAR);

    SPAGAIN;
    funcref = POPs;
    SvREFCNT_inc(funcref);
    PUTBACK;
    LEAVE;
    return funcref;
}

/* Handles userdata variables.
 * Those could be filehandles, for instance */

SV*
user_data (lua_State *L) {
    FILE **f = luaL_checkudata(L, 1, "FILE*");

    if (!f)
	croak("Attempt to return unsupported Lua type (userdata)");

    if (*f) {
	PerlIO *pio = PerlIO_importFILE(*f, NULL);
	GV *gv = newGVgen("Inline::Lua");
	if (do_open(gv, "+<&", 3, FALSE, 0, 0, pio)) {
	    SV *sv = NEWSV(0,0);
	    sv_setsv(sv, sv_bless(newRV((SV*)gv), gv_stashpv("Inline::Lua", 1)));
	    return sv;
	} else
	    return &PL_sv_undef;
    } else
	croak("Attempt to return closed filehandle");
}


MODULE = Inline::Lua		PACKAGE = Inline::Lua

BOOT:
{
    LuaNil = get_sv("Inline::Lua::Nil", 1);
    sv_setref_pv(LuaNil, "Inline::Lua::Nil", (void*)&PL_sv_undef);
    SvREADONLY_on(LuaNil);
    INLINE_RETURN = newAV();
}

INCLUDE: const-xs.inc

void
register_undef (CLASS, undef)
	SV *CLASS;
	SV *undef;
    CODE:
    {
	UNDEF = undef;
	SvREFCNT_inc(undef);
    }

lua_State *
interpreter (CLASS, ...)
	char *CLASS;
    CODE:
	{
	    char *from_file = NULL;
	    STRLEN n_a;

	    if (items > 1)
		from_file = SvPV(ST(1), n_a);

	    if (!INTERPRETER) {
		RETVAL = INTERPRETER = luaL_newstate();
		if (INTERPRETER) {
		    luaL_openlibs(INTERPRETER);
		}
	    }
	    else
		RETVAL = INTERPRETER;
	}
    OUTPUT:
	RETVAL

void
destroy (lua)
	lua_State *lua;
    CODE:
    {
	lua_close(lua);
    }

void
compile (lua, code, file, dump)
	lua_State *lua;
	SV *code;
	char *file;
	I32 dump;
    CODE:
    {
	STRLEN len;
	char *codestr = SvPV(code, len);
	int i = 1;
	int status;

	status = luaL_loadbuffer(lua, codestr, len, "_INLINED_LUA");

	if (dump && status == 0) {
	    FILE *f = fopen(file, "w");
	    if (f) {
#if LUA_VERSION_NUM < 503
		lua_dump(lua, dumper, (void*)f);
#else
                // Lua 5.3 introduces the strip parameter for lua_dump
		lua_dump(lua, dumper, (void*)f, 0);
#endif
		fclose(f);
	    } else
		croak("Error outputting bytecode to %s: %s\n", file, strerror(errno));
	    XSRETURN_YES;
	}

	switch (status) {
	    case 0:
		{
		int nargs = lua_gettop(lua);
		if ((lua_pcall(lua, 0, LUA_MULTRET, 0)) == 0) {
		    if (lua_gettop(lua) - nargs >= 0)
			INLINE_RETURN = lua_main_return(lua, lua_gettop(lua), nargs);
		    lua_pop(lua, lua_gettop(lua));
		    XSRETURN_YES;
		}
		else
		    croak("error: %s", lua_tostring(lua, -1));
		break;
		}
	    case LUA_ERRSYNTAX:
		croak("Couldn't compile inline code");
	}
    }

void
call (lua, func, nargs, ...)
	lua_State *lua;
	SV *func;
	int nargs;
    PPCODE:
    {
	char *name;
	int ref;
	int i = 0, j, status;
	int actual_args = 0;

	if (SvPOK(func)) {
	    STRLEN n_a;
	    name = SvPV(func, n_a);
	    lua_getglobal(lua, name);
	} else {
	    /* function reference */
	    lua_rawgeti(lua, LUA_REGISTRYINDEX, SvIV(func));
	}


	/* push arguments */
	for (i = 0; i < items-3; i++, nargs--, actual_args++) {
	    push_val(lua, ST(i+3));
	}

	/* if less arguments were passed than mentioned in the
	 * lua function prototype, pad with 'nil' */
	if (nargs >= 0)
	    for (i = nargs; i > 0; nargs--, actual_args++, i--)
		push_val(lua, NULL);
	status = lua_pcall(lua, actual_args, LUA_MULTRET, 0);

	if (status != 0) {
            SV *error_msg = mess("error: %s\n", lua_tostring(lua, -1));
            lua_pop(lua, 1);
	    croak_sv(error_msg);
        }

	/* return args to caller:
	 * lua functions appear to push their return values in reverse order */
	nargs = lua_gettop(lua);
	EXTEND(SP, nargs);
	j = 1;
	while (i = lua_gettop(lua)) {
	    switch(lua_type(lua, i)) {
		case LUA_TNIL:
		    ST(nargs - j++) = &PL_sv_undef;
		    break;
		case LUA_TNUMBER:
		    ST(nargs - j++) = sv_2mortal(newSVnv(lua_tonumber(lua, i)));
		    break;
		case LUA_TBOOLEAN:
		    ST(nargs - j++) = sv_2mortal(bool_ref(lua, lua_toboolean(lua, i)));
		    break;
		case LUA_TSTRING:
		    {
		    STRLEN len = lua_strlen(lua, i);
		    ST(nargs - j++) = sv_2mortal(newSVpvn(lua_tostring(lua, i), len));
		    }
		    break;
		case LUA_TTABLE:
		    ST(nargs - j++) = sv_2mortal(table_ref(lua, i));
		    break;
		case LUA_TFUNCTION:
		    {
		    ST(nargs - j++) = sv_2mortal(func_ref(lua));
		    goto no_pop;
		    }
		case LUA_TUSERDATA:
		    ST(nargs - j++) = sv_2mortal(user_data(lua));
		    break;
		default:
		    croak("Attempt to return unsupported Lua type (%s)", lua_typename(lua, lua_type(lua, i)));
	    }
	    lua_pop(lua, 1);
	    no_pop:
	    continue;
	}
	XSRETURN(j-1);
    }

void
main_returns (CLASS)
	char *CLASS;
    PPCODE:
	{
	    register int i;
	    int len = av_len(INLINE_RETURN) + 1;
	    EXTEND(SP, len);
	    for (i = 0; i < len; i++) {
		SV **ptr = av_fetch(INLINE_RETURN, i, FALSE);
		if (ptr)
		    PUSHs(*ptr);
		else
		    PUSHs(&PL_sv_undef);
	    }
	    XSRETURN(len);
	}