The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
/*
 * Marpa::R3 is Copyright (C) 2017, Jeffrey Kegler.
 *
 * This module is free software; you can redistribute it and/or modify it
 * under the same terms as Perl 5.10.1. For more details, see the full text
 * of the licenses in the directory LICENSES.
 *
 * This program is distributed in the hope that it will be
 * useful, but it is provided "as is" and without any express
 * or implied warranties. For details, see the full text of
 * of the licenses in the directory LICENSES.
 */

/* TODO: Eliminate this? */
#include "marpa.h"

/* TODO: Replace error codes with Lua equivalent? */
#include "marpa_codes.h"

#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include "ppport.h"

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

#undef LUAOPEN_KOLLOS_METAL
#define LUAOPEN_KOLLOS_METAL kollos_metal_loader
#include <kollos.h>

/* TODO: Replace this with Lua equivalent? */
extern const struct marpa_error_description_s marpa_error_description[];

typedef struct
{
  lua_State* L;
} Marpa_Lua;

#undef IS_PERL_UNDEF
#define IS_PERL_UNDEF(x) (SvTYPE(x) == SVt_NULL)

#undef STRINGIFY_ARG
#undef STRINGIFY
#undef STRLOC
#define STRINGIFY_ARG(contents)       #contents
#define STRINGIFY(macro_or_string)        STRINGIFY_ARG (macro_or_string)
#define STRLOC        __FILE__ ":" STRINGIFY (__LINE__)

#undef MYLUA_TAG
#define MYLUA_TAG "@" STRLOC

/* The usual lua_checkstack argument.
 * It's generous so I can defer stack hygiene --
 * that is, not clean up the stack immediately,
 * but leave things that I know will be cleaned up
 * shortly.
 *
 * If you're counting, don't forget that the error
 * handlers will want a few extra stack slots, if
 * invoked.
 */
#undef MYLUA_STACK_INCR
#define MYLUA_STACK_INCR 30

/* Start all Marpa::R3 internal errors with the same string */
#undef R3ERR
#define R3ERR "Marpa::R3 internal error: "

#undef MAX
#define MAX(a, b) ((a) > (b) ? (a) : (b))

typedef SV* SVREF;

#undef Dim
#define Dim(x) (sizeof(x)/sizeof(*x))

struct lua_extraspace {
    int ref_count;
};

/* I assume this will be inlined by the compiler */
static struct lua_extraspace *extraspace_get(lua_State* L)
{
    return *(struct lua_extraspace **)marpa_lua_getextraspace(L);
}

static void lua_refinc(lua_State* L) PERL_UNUSED_DECL;
static void lua_refinc(lua_State* L)
{
    struct lua_extraspace *p_extra = extraspace_get(L);
    p_extra->ref_count++;
}

static void lua_refdec(lua_State* L)
{
    struct lua_extraspace *p_extra = extraspace_get(L);
    p_extra->ref_count--;
    if (p_extra->ref_count <= 0) {
       marpa_lua_close(L);
       free(p_extra);
    }
}

static const char marpa_lua_class_name[] = "Marpa::R3::Lua";

/* Wrapper to use vwarn with libmarpa */
static int marpa_r3_warn(const char* format, ...)
{
  dTHX;
   va_list args;
   va_start (args, format);
   vwarn (format, &args);
   va_end (args);
   return 1;
}

/* Xlua, that is, the eXtension of Lua for Marpa::XS.
 * Portions of this code adopted from Inline::Lua
 */

#define MT_NAME_SV "Glue_sv"

/* Returns 0 if visitee_ix "thing" is already "seen",
 * otherwise, sets it "seen" and returns 1.
 * A small fixed number of stack entries are used
 * -- stack hygiene is left to the caller.
 */
static int visitee_on(
  lua_State* L, int seen_ix, int visitee_ix)
{
    marpa_lua_pushvalue(L, visitee_ix);
    if (marpa_lua_gettable(L, seen_ix) != LUA_TNIL) {
        return 0;
    }
    marpa_lua_pushvalue(L, visitee_ix);
    marpa_lua_pushboolean(L, 1);
    marpa_lua_settable(L, seen_ix);
    return 1;
}

/* Unsets "seen" for Lua "thing" at visitee_ix in
 * the table at seen_ix.
 * A small fixed number of stack entries are used
 * -- stack hygiene is left to the caller.
 */
static void visitee_off(
  lua_State* L, int seen_ix, int visitee_ix)
{
    marpa_lua_pushvalue(L, visitee_ix);
    marpa_lua_pushnil(L);
    marpa_lua_settable(L, seen_ix);
}

static SV*
recursive_coerce_to_sv (lua_State * L, int visited_ix, int idx, char sig);
static SV*
coerce_to_av (lua_State * L, int visited_ix, int table_ix, char signature);
static SV*
coerce_to_pairs (lua_State * L, int visited_ix, int table_ix);

/* Coerce a Lua value to a Perl SV, if necessary one that
 * is simply a string with an error message.
 * The caller gets ownership of one of the SV's reference
 * counts.
 * The Lua stack is left as is.
 */
static SV*
coerce_to_sv (lua_State * L, int idx, char sig)
{
   dTHX;
   SV *result;
   int visited_ix;
   int absolute_index = marpa_lua_absindex(L, idx);

   marpa_lua_newtable(L);
   visited_ix = marpa_lua_gettop(L);
   result = recursive_coerce_to_sv(L, visited_ix, absolute_index, sig);
   marpa_lua_settop(L, visited_ix-1);
   return result;
}

/* Reworked from Lua's utf8_decode.
 * We cannot use the XS Unicode routines, because
 * we are checking for standard Unicode, which Lua
 * uses, and Perl extends UTF-8.
 */
static const char *utf8_validate (const char *o, int max_size) {
  const lua_Integer maxunicode= 0x10FFFF;
  static const unsigned int limits[] = {0xFF, 0x7F, 0x7FF, 0xFFFF};
  const unsigned char *s = (const unsigned char *)o;
  unsigned int c = (unsigned int)s[0];
  unsigned int res = 0;  /* final result */
  if (max_size <= 0) return NULL;
  if (c <= 0x7F)  /* ascii? */
    res = c;
  else {
    int count = 0;  /* to count number of continuation bytes */
    while (c & 0x40) {  /* still have continuation bytes? */
      int cc;
      ++count;
      if (count + 1 > max_size) return NULL;
      cc = s[count];  /* read next byte */
      if ((cc & 0xC0) != 0x80)  /* not a continuation byte? */
        return NULL;  /* invalid byte sequence */
      res = (res << 6) | (cc & 0x3F);  /* add lower 6 bits from cont. byte */
      c <<= 1;  /* to test next bit */
    }
    res |= ((c & 0x7F) << (count * 5));  /* add first byte */
    if (count > 3 || res > maxunicode || res <= limits[count])
      return NULL;  /* invalid byte sequence */
    s += count;  /* skip continuation bytes read */
  }
  return (const char *)s + 1;  /* +1 to include first byte */
}

static int find_utf8_error (const char *s, const char *end) {
  const char *s1 = s;
  while (s1 < end) {
    /* warn("%s %d before s1=%p\n", __FILE__, __LINE__, s1); */
    s1 = utf8_validate(s1, (int)(end - s1));
    /* warn("%s %d after s1=%p\n", __FILE__, __LINE__, s1); */
    if (s1 == NULL) return (int)(s1 - s);
  }
  return -1;
}

static int is_ascii7 (const char *s, size_t length) {
    size_t i;
    for (i = 0; i < length; i++) {
        if (s[i] & 0x80) return 0;
    }
    return 1;
}

static SV*
recursive_coerce_to_sv (lua_State * L, int visited_ix, int idx, char signature)
{
    dTHX;
    SV *result;
    const int type = marpa_lua_type (L, idx);

    /* warn("%s %d\n", __FILE__, __LINE__); */
    switch (type) {
    case LUA_TNIL:
        /* warn("%s %d\n", __FILE__, __LINE__); */
        result = newSV (0);
        break;
    case LUA_TBOOLEAN:
        /* warn("%s %d\n", __FILE__, __LINE__); */
        result = marpa_lua_toboolean (L, idx) ? newSViv (1) : newSV (0);
        break;
    case LUA_TNUMBER:
        if (marpa_lua_isinteger (L, idx)) {
            lua_Integer int_v = marpa_lua_tointeger (L, idx);
            if (int_v <= IV_MAX && int_v >= IV_MIN) {
                result = newSViv ((IV) marpa_lua_tointeger (L, idx));
                break;
            }
        }
        result = newSVnv (marpa_lua_tonumber (L, idx));
        break;
    case LUA_TSTRING:
        /* warn("%s %d: %s len=%d\n", __FILE__, __LINE__, marpa_lua_tostring (L, idx), marpa_lua_rawlen (L, idx)); */
        {
            size_t str_length;
            const char *str = marpa_lua_tolstring (L, idx, &str_length);
            result = newSVpvn (str, (STRLEN)str_length);
            if (!is_ascii7(str, str_length)) SvUTF8_on(result);
        }
        break;
    case LUA_TTABLE:
        {
            switch (signature) {
            default:
            case '0':
            case '1':
                result = coerce_to_av (L, visited_ix, idx, signature);
                break;
            case '2':
                result = coerce_to_pairs (L, visited_ix, idx);
                break;
            }
        }
        break;
    case LUA_TUSERDATA:
        {
            SV **p_result = marpa_luaL_testudata (L, idx, MT_NAME_SV);
            if (!p_result) {
                result =
                    newSVpvf
                    ("Coercion not implemented for Lua userdata at index %d in coerce_to_sv",
                    idx);
            } else {
                result = *p_result;
                SvREFCNT_inc_simple_void_NN (result);
            }
        };
        break;

    default:
        /* warn("%s %d\n", __FILE__, __LINE__); */
        result =
            newSVpvf
            ("Lua type %s at index %d in coerce_to_sv: coercion not implemented",
            marpa_luaL_typename (L, idx), idx);
        break;
    }
    /* warn("%s %d\n", __FILE__, __LINE__); */
    return result;
}

/* Coerce a Lua table to an AV.  Cycles are checked for
 * and cut off with a string marking the cutoff point.
 * Only numeric keys in a Lua "sequence" are considered:
 * that is, keys 1 .. N where N is the length of the sequence
 * and none of the values are nil.  If the signature is '0',
 * the sequence will converted to a zero-based Perl array,
 * so that a conventional Lua sequence is converted to a
 * convention-compliant Perl array.  If the signature is '1'
 * the keys in the Perl array will be exactly those of the
 * Lua sequence.
 */
static SV*
coerce_to_av (lua_State * L, int visited_ix, int table_ix, char signature)
{
    dTHX;
    SV *result;
    AV *av;
    int seq_ix;
    const int base_of_stack = marpa_lua_gettop(L);
    const int ix_offset = signature == '1' ? 0 : -1;

    /* warn("%s %d table_ix=%ld signature=%c\n", __FILE__, __LINE__, table_ix, signature); */

    marpa_lua_pushvalue(L, table_ix);
    if (!visitee_on(L, visited_ix, table_ix)) {
        result = newSVpvs ("[cycle in lua table]");
        goto RESET_STACK;
    }

    /* Below we will call this recursively,
     * so we need to make sure we have enough stack
     */
    marpa_luaL_checkstack(L, MYLUA_STACK_INCR, MYLUA_TAG);

    av = newAV();
    /* mortalize it, so it is garbage collected if we abend */
    result = sv_2mortal (newRV_noinc ((SV *) av));

    for (seq_ix = 1; 1; seq_ix++)
    {
        int value_ix;
	SV *entry_value;
	SV** ownership_taken;
        const int type_pushed = marpa_lua_geti(L, table_ix, seq_ix);
        /* warn("%s %d seq_ix=%ld\n", __FILE__, __LINE__, seq_ix); */

        if (type_pushed == LUA_TNIL) { break; }
        value_ix = marpa_lua_gettop(L); /* We need an absolute index, not -1 */
        /* warn("%s %d value_ix=%ld\n", __FILE__, __LINE__, value_ix); */
	entry_value = recursive_coerce_to_sv(L, visited_ix, value_ix, signature);
	ownership_taken = av_store(av, (int)seq_ix + ix_offset, entry_value);
        marpa_lua_settop(L, value_ix - 1);
	if (!ownership_taken) {
	  SvREFCNT_dec (entry_value);
          croak (R3ERR "av_store failed; " MYLUA_TAG);
	}
    }

    /* Demortalize the result, now that we know we will not
     * abend.
     */
    SvREFCNT_inc_simple_void_NN (result);
    visitee_off(L, visited_ix, table_ix);

    RESET_STACK:
    marpa_lua_settop(L, base_of_stack);
    return result;
}

/* Coerce a Lua table to an AV of key-value pairs.
 * Cycles are checked for
 * and cut off with a string marking the cutoff point.
 * The numeric keys in a Lua "sequence" are put first.
 * Other key-value pairs follow in random order.
 * The result will be a zero-based Perl array,
 */
static SV*
coerce_to_pairs (lua_State * L, int visited_ix, int table_ix)
{
    dTHX;
    SV *result;
    AV *av;
    lua_Integer seq_length;
    int av_ix = 0;
    const int base_of_stack = marpa_lua_gettop(L);


    marpa_lua_pushvalue(L, table_ix);
    if (!visitee_on(L, visited_ix, table_ix)) {
        result = newSVpvs ("[cycle in lua table]");
        goto RESET_STACK;
    }

    /* We call this recursively, so we need to make sure we have enough stack */
    marpa_luaL_checkstack(L, MYLUA_STACK_INCR, MYLUA_TAG);

    av = newAV();
    /* mortalize it, so it is garbage collected if we abend */
    result = sv_2mortal (newRV_noinc ((SV *) av));

    {
        const int base_of_loop_stack = marpa_lua_gettop (L);
        const int loop_value_ix = base_of_loop_stack + 1;
        int seq_ix;
        for (seq_ix = 1; 1; seq_ix++) {
            SV *entry_value;
            SV **ownership_taken;

            const int type_pushed = marpa_lua_geti (L, table_ix, seq_ix);

            if (type_pushed == LUA_TNIL) {
                break;
            }


            entry_value = newSViv (seq_ix);
            ownership_taken = av_store (av, (int) av_ix, entry_value);
            if (!ownership_taken) {
                SvREFCNT_dec (entry_value);
                croak (R3ERR "av_store failed; " MYLUA_TAG);
            }
            av_ix++;

            entry_value =
                recursive_coerce_to_sv (L, visited_ix, loop_value_ix, '2');
            ownership_taken = av_store (av, (int) av_ix, entry_value);
            if (!ownership_taken) {
                SvREFCNT_dec (entry_value);
                croak (R3ERR "av_store failed; " MYLUA_TAG);
            }
            av_ix++;
            marpa_lua_settop (L, base_of_loop_stack);
        }
        seq_length = seq_ix - 1;
    }

    /* Now do the key-value pairs that were *NOT* part
     * of the sequence
     */
    marpa_lua_pushnil(L);
    while (marpa_lua_next(L, table_ix) != 0) {
        SV** ownership_taken;
        SV *entry_value;
        const int value_ix = marpa_lua_gettop(L);
        const int key_ix = value_ix - 1;
        int key_type = marpa_lua_type(L, key_ix);

        /* Sequence elements have already been entered, so skip
         * them
         */
        if (key_type == LUA_TNUMBER) {
            int isnum;
            lua_Integer key_value = marpa_lua_tointegerx(L, key_ix, &isnum);
            if (!isnum) goto NEXT_ELEMENT;
            if (key_value >= 1 && key_value <= seq_length) goto NEXT_ELEMENT;
        }

	entry_value = recursive_coerce_to_sv(L, visited_ix, key_ix, '2');
	ownership_taken = av_store(av, (int)av_ix, entry_value);
	if (!ownership_taken) {
	  SvREFCNT_dec (entry_value);
          croak (R3ERR "av_store failed; " MYLUA_TAG);
	}
        av_ix ++;

	entry_value = recursive_coerce_to_sv(L, visited_ix, value_ix, '2');
	ownership_taken = av_store(av, (int)av_ix, entry_value);
	if (!ownership_taken) {
	  SvREFCNT_dec (entry_value);
          croak (R3ERR "av_store failed; " MYLUA_TAG);
	}
        av_ix ++;

        NEXT_ELEMENT: ;
        marpa_lua_settop(L, key_ix);
    }

    /* Demortalize the result, now that we know we will not
     * abend.
     */
    SvREFCNT_inc_simple_void_NN (result);
    visitee_off(L, visited_ix, table_ix);

    RESET_STACK:
    marpa_lua_settop(L, base_of_stack);
    return result;
}

/* [ -1, +1 ]
 * Wraps the object on top of the stack in an
 * X_fallback object.  Removes the original object
 * from the stack, and leaves the wrapper on top
 * of the stack.  Obeys stack hygiene.
 */
static void X_fallback_wrap(lua_State* L)
{
     /* [ object ] */
     marpa_lua_newtable(L);
     /* [ object, wrapper ] */
     marpa_lua_rawgetp (L, LUA_REGISTRYINDEX, (void*)&kollos_X_fallback_mt_key);
     marpa_lua_setmetatable(L, -2);
     /* [ object, wrapper ] */
     marpa_lua_rotate(L, -2, 1);
     /* [ wrapper, object ] */
     marpa_lua_setfield(L, -2, "object");
     /* [ wrapper ] */
}

/* Called after pcall error -- assumes that "status" is
 * the non-zero return value of lua_pcall() and that the
 * error object is on top of the stack.  Leaves an
 * "exception object" on top of the stack, and in
 * a global.  At this point, the "exception object"
 * might simply be a string.
 *
 * Does *NOT* do stack hygiene.
 */
static void coerce_pcall_error (lua_State* L, int status) {
    switch (status) {
    case LUA_ERRERR:
        marpa_lua_pushliteral(L, R3ERR "pcall(); error running the message handler");
        break;
    case LUA_ERRMEM:
        marpa_lua_pushliteral(L, R3ERR "pcall(); error running the message handler");
        break;
    case LUA_ERRGCMM:
        marpa_lua_pushliteral(L, R3ERR "pcall(); error running a gc_ metamethod");
        break;
    default:
        marpa_lua_pushfstring(L, R3ERR "pcall(); bad status %d", status);
        break;
    case LUA_ERRRUN:
        /* Just leave the original object on top of the stack */
        break;
    }
    return;
}

/* Called after pcall error -- assumes that "status" is
 * the non-zero return value of lua_pcall() and that the
 * error object is on top of the stack.  Leaves the exception
 * object on top of the stack.  Does stack hygiene.
 *
 * The return value is a string which is either a C constant string
 * in static space, or in Perl mortal space.
 */
static const char* handle_pcall_error (lua_State* L, int status) {
    dTHX;
    /* Lua stack: [ exception_object ] */
    const int exception_object_ix = marpa_lua_gettop(L);

    /* The best way to get a self-expanding sprintf buffer is to use a
     * Perl SV.  We set it mortal, so that Perl makes sure that it is
     * garbage collected after the next context switch.
     */
    SV* temp_sv = sv_newmortal();

    /* This is in the context of an error, so we have to be careful
     * about having enough Lua stack.
     */
    marpa_luaL_checkstack(L, MYLUA_STACK_INCR, MYLUA_TAG);

    coerce_pcall_error(L, status);
    marpa_lua_pushvalue(L, -1);
    marpa_lua_setglobal(L, "last_exception");

    {
        size_t len;
        const char *lua_exception_string = marpa_luaL_tolstring(L, -1, &len);
        sv_setpvn(temp_sv, lua_exception_string, (STRLEN)len);
    }

    marpa_lua_settop(L, exception_object_ix-1);
    return SvPV_nolen(temp_sv);
}

/* Push a Perl value onto the Lua stack. */
static void
push_val (lua_State * L, SV * val)
{
  dTHX;
  if (SvTYPE (val) == SVt_NULL)
    {
      /* warn("%s %d\n", __FILE__, __LINE__); */
      marpa_lua_pushnil (L);
      return;
    }
  if (SvPOK (val))
    {
      STRLEN n_a;
      /* warn("%s %d\n", __FILE__, __LINE__); */
      char *cval = SvPV (val, n_a);
      marpa_lua_pushlstring (L, cval, n_a);
      return;
    }
  if (SvNOK (val))
    {
      /* warn("%s %d\n", __FILE__, __LINE__); */
      marpa_lua_pushnumber (L, (lua_Number) SvNV (val));
      return;
    }
  if (SvIOK (val))
    {
      /* warn("%s %d\n", __FILE__, __LINE__); */
      marpa_lua_pushnumber (L, (lua_Number) SvIV (val));
      return;
    }
  if (SvROK (val))
    {
      /* warn("%s %d\n", __FILE__, __LINE__); */
      marpa_lua_pushfstring (L,
                             "[Perl ref to type %s]",
                             sv_reftype (SvRV (val), 0));
      return;
    }
      /* warn("%s %d\n", __FILE__, __LINE__); */
  marpa_lua_pushfstring (L, "[Perl type %d]",
                         SvTYPE (val));
  return;
}

/* [0, +1] */
/* Creates a userdata containing a Perl SV, and
 * leaves the new userdata on top of the stack.
 * The new Lua userdata takes ownership of one reference count.
 * The caller must have a reference count whose ownership
 * the caller is prepared to transfer to the Lua userdata.
 */
static void glue_sv_sv_noinc (lua_State* L, SV* sv) {
    SV** p_sv = (SV**)marpa_lua_newuserdata(L, sizeof(SV*));
    *p_sv = sv;
    /* warn("new ud %p, SV %p %s %d\n", p_sv, sv, __FILE__, __LINE__); */
    marpa_luaL_getmetatable(L, MT_NAME_SV);
    marpa_lua_setmetatable(L, -2);
    /* [sv_userdata] */
}

#define MARPA_SV_SV(L, sv) \
    (glue_sv_sv_noinc((L), (sv)), SvREFCNT_inc_simple_void_NN (sv))

static int glue_sv_finalize_meth (lua_State* L) {
    dTHX;
    /* Is this check necessary after development? */
    SV** p_sv = (SV**)marpa_luaL_checkudata(L, 1, MT_NAME_SV);
    SV* sv = *p_sv;
    /* warn("decrementing ud %p, SV %p, %s %d\n", p_sv, sv, __FILE__, __LINE__); */
    SvREFCNT_dec (sv);
    return 0;
}

/* Basically a Lua wrapper for Perl's sv_dump()
 */
static int
glue_sv_dump_func (lua_State * L)
{
    dTHX;
    SV **const p_sv = (SV **) marpa_luaL_testudata (L, 1, MT_NAME_SV);
    if (!p_sv) {
      warn("Not an MT_NAME_SV userdata, type =%s\n",
            marpa_luaL_typename (L, 1));
      return 0;
    }
    sv_dump(*p_sv);
    return 0;
}

static int glue_sv_tostring_meth(lua_State* L) {
    /* Lua stack: [ sv_userdata ] */
    /* After development, check not needed */
    SV** p_table_sv = (SV**)marpa_luaL_checkudata(L, 1, MT_NAME_SV);
    marpa_lua_getglobal(L, "tostring");
    /* Lua stack: [ sv_userdata, to_string_fn ] */
    push_val (L, *p_table_sv);
    /* Lua stack: [ sv_userdata, to_string_fn, lua_equiv_of_sv ] */
    marpa_lua_call(L, 1, 1);
    /* Lua stack: [ sv_userdata, string_equiv_of_sv ] */
    if (!marpa_lua_isstring(L, -1)) {
       croak("sv could not be converted to string");
    }
    return 1;
}

static int glue_sv_svaddr_meth(lua_State* L) {
    /* Lua stack: [ sv_userdata ] */
    /* For debugging, so keep the check even after development */
    SV** p_table_sv = (SV**)marpa_luaL_checkudata(L, 1, MT_NAME_SV);
    marpa_lua_pushinteger (L, (lua_Integer)PTR2nat(*p_table_sv));
    return 1;
}

static int glue_sv_addr_meth(lua_State* L) {
    /* Lua stack: [ sv_userdata ] */
    /* For debugging, so keep the check even after development */
    SV** p_table_sv = (SV**)marpa_luaL_checkudata(L, 1, MT_NAME_SV);
    marpa_lua_pushinteger (L, (lua_Integer)PTR2nat(p_table_sv));
    return 1;
}

static const struct luaL_Reg glue_sv_meths[] = {
    {"__gc", glue_sv_finalize_meth},
    {"__tostring", glue_sv_tostring_meth},
    {NULL, NULL},
};

static const struct luaL_Reg glue_sv_funcs[] = {
    {"svaddr", glue_sv_svaddr_meth},
    {"addr", glue_sv_addr_meth},
    {NULL, NULL},
};

static const struct luaL_Reg glue_funcs[] = {
    {"sv_dump", glue_sv_dump_func},
    {NULL, NULL},
};

/*
 * Message handler used to run all chunks
 * The message processing can be significant.
 * Here I try to do the minimum necessary to grab the traceback
 * data.
 */
static int glue_msghandler (lua_State *L) {
  const int original_type = marpa_lua_type(L, -1);
  int traceback_type;
  int result_ix;
  int is_X = 0;
  if (original_type == LUA_TSTRING) {
    const char *msg = marpa_lua_tolstring(L, 1, NULL);
    marpa_luaL_traceback(L, L, msg, 1);  /* append a standard traceback */
    return 1;
  }
  result_ix = marpa_lua_gettop(L);
  /* Is this an exception object table */
  if (original_type == LUA_TTABLE) {
     marpa_lua_getmetatable(L, -1);
     marpa_lua_rawgetp (L, LUA_REGISTRYINDEX, &kollos_X_mt_key);
     is_X = marpa_lua_compare (L, -2, -1, LUA_OPEQ);
  }
  if (!is_X) {
    X_fallback_wrap(L);
    result_ix = marpa_lua_gettop(L);
  }
  /* At this point the exception table that will be
   * the result is the top of stack
   */
  traceback_type = marpa_lua_getfield(L, result_ix, "traceback");
  /* Default (i.e, nil) is "true" */
  if (traceback_type == LUA_TNIL || marpa_lua_toboolean(L, -1)) {
    /* result.where = debug.traceback() */
    marpa_luaL_traceback(L, L, NULL, 1);
    marpa_lua_setfield(L, result_ix, "where");
  }
  marpa_lua_settop(L, result_ix);
  return 1;
}

static void recursive_coerce_to_lua(
  lua_State* L, int visited_ix, SV *sv, char sig);

static void
coerce_to_lua (lua_State * L, SV *sv, char sig)
{
   dTHX;
   int visited_ix;

   marpa_lua_newtable(L);
   visited_ix = marpa_lua_gettop(L);
   recursive_coerce_to_lua(L, visited_ix, sv, sig);
   /* Replaces the visited table with the result */
   marpa_lua_copy(L, -1, visited_ix);
   /* Leaves the result on top of the stack */
   marpa_lua_settop(L, visited_ix);
   return;
}

/* Caller must ensure that `av` is in fact
 * an AV.
 */
static void coerce_to_lua_sequence(
  lua_State* L, int visited_ix, AV *av, char sig)
{
    dTHX;
    SSize_t last_perl_ix;
    I32 perl_ix;
    int lud_ix;
    int result_ix;

    /* A light user data is used to provide a unique
     * value for the "visited table".  This address is
     * TOS+1, where TOS is the top of stack when this
     * function was called.  This location will also
     * contain the return value
     */

    marpa_lua_pushlightuserdata(L, (void*)av);
    lud_ix = marpa_lua_gettop(L);
    if (!visitee_on(L, visited_ix, lud_ix)) {
        marpa_lua_pushliteral(L, "[cycle in Perl array]");
        result_ix = marpa_lua_gettop (L);
        goto RESET_STACK;
    }

    /* Below we will call this recursively,
     * so we need to make sure we have enough stack
     */
    marpa_luaL_checkstack(L, MYLUA_STACK_INCR, MYLUA_TAG);

    marpa_lua_newtable(L);
    result_ix = marpa_lua_gettop(L);
    last_perl_ix = av_len(av);
    for (perl_ix = 0; perl_ix <= last_perl_ix; perl_ix++) {
       /* warn("%s %d fetching perl array index %ld\n", __FILE__, __LINE__, (long)(perl_ix)); */
       SV** p_sv = av_fetch(av, perl_ix, 0);
       if (p_sv) {
           recursive_coerce_to_lua(L, visited_ix, *p_sv, sig);
       } else {
           marpa_lua_pushboolean(L, 0);
       }
       /* warn("%s %d setting lua array index %ld\n", __FILE__, __LINE__, (long)(perl_ix+1)); */
       marpa_lua_seti(L, result_ix, perl_ix+1);
    }

    visitee_off(L, visited_ix, lud_ix);

    RESET_STACK:

    /* Replaces the lud with the result */
    marpa_lua_copy(L, result_ix, lud_ix);
    marpa_lua_settop(L, lud_ix);
}

/* [0, +1] */
/* Caller must ensure that `hv` is in fact
 * an HV.
 * All Perl hash keys are converted to Lua
 * string keys, and the values are converted
 * recursively according to "sig".
 */
static void coerce_to_lua_table(
  lua_State* L, int visited_ix, HV *hv, char sig)
{
    dTHX;
    int lud_ix;
    int result_ix;

    /* A light user data is used to provide a unique
     * value for the "visited table".  This address is
     * TOS+1, where TOS is the top of stack when this
     * function was called.  This location will also
     * contain the return value
     */
    marpa_lua_pushlightuserdata (L, (void *) hv);
    lud_ix = marpa_lua_gettop (L);
    if (!visitee_on (L, visited_ix, lud_ix)) {
        marpa_lua_pushliteral (L, "[cycle in Perl hash]");
        result_ix = marpa_lua_gettop (L);
        goto RESET_STACK;
    }

    /* Below we will call this recursively,
     * so we need to make sure we have enough stack
     */
    marpa_luaL_checkstack (L, MYLUA_STACK_INCR, MYLUA_TAG);

    marpa_lua_newtable (L);
    result_ix = marpa_lua_gettop (L);
    hv_iterinit (hv);
    {
        HE *entry;
        while ((entry = hv_iternext (hv))) {

            SV *val = hv_iterval(hv, entry);

            /* We must use hv_iterkeysv() because hv_iterkey() fails
             * for certain Unicode keys -- U+00C1 being one.
             */
            SV* keysv = hv_iterkeysv(entry);
            STRLEN keylen;
            const char *key = SvPV (keysv, keylen);

            int error_pos = find_utf8_error(key, key+keylen);
            if (error_pos >= 0) {
               croak("Non-UTF-8 string ('%.10s') passed to Marpa, problem at pos=%ld, '%.10s'",
                    key, (long)error_pos, key+error_pos);
            }

            /* warn("%s %d pushing Perl hash key as lua string %.10s klen=%ld", __FILE__, __LINE__, key, (long)klen); */
            /* warn("%s %d 1-length Perl hash key %lx", __FILE__, __LINE__, (long)*key); */
            /* warn("from hv_iterkeysv(): length=%ld, key[0]=%lx key[1]=%lx", (long)len, (long)s[0], (long)s[1]); */

            marpa_lua_pushlstring (L, key, (size_t)keylen);

            recursive_coerce_to_lua (L, visited_ix, val, sig);
            marpa_lua_settable (L, result_ix);
        }
    }

    visitee_off (L, visited_ix, lud_ix);

  RESET_STACK:

    /* Replaces the lud with the result */
    marpa_lua_copy (L, result_ix, lud_ix);
    marpa_lua_settop (L, lud_ix);
}

/* Coerce an SV to Lua, leaving it on the stack */
static void recursive_coerce_to_lua(
  lua_State* L, int visited_ix, SV *sv, char sig)
{
    dTHX;

    if (sig == 'S') {
        SV* newsv = newSVsv(sv);
        glue_sv_sv_noinc (L, newsv);
        return;
    }

    if (!SvOK(sv)) {
        marpa_lua_pushnil (L);
        return;
    }

    if (SvROK(sv)) {
        SV* referent = SvRV(sv);
        if (SvTYPE(referent) == SVt_PVAV) {
            coerce_to_lua_sequence(L, visited_ix, (AV*)referent, sig);
            return;
        }
        if (SvTYPE(referent) == SVt_PVHV) {
            coerce_to_lua_table(L, visited_ix, (HV*)referent, sig);
            return;
        }
        goto DEFAULT_TO_STRING;
    }

    switch(sig) {
    case 'i':
        if (SvIOK(sv)) {
          marpa_lua_pushinteger (L, (lua_Integer) SvIV (sv));
          return;
        }
        break;
    case 'n':
        if (SvNIOK(sv)) {
          marpa_lua_pushnumber (L, (lua_Number) SvNV (sv));
          return;
        }
        break;
    case 's': break;
    default:
        croak
            ("Internal error: invalid sig option %c in xlua EXEC_SIG_BODY", sig);
    }

    DEFAULT_TO_STRING:
    /* If here, we are coercing to a string */
    {
      STRLEN len;
      const char *s = SvPV (sv, len);
      int error_pos = find_utf8_error(s, s+len);
      if (error_pos >= 0) {
         croak("Non-UTF-8 string ('%.10s') passed to Marpa, problem at pos=%ld, '%.10s'",
              s, (long)error_pos, s+error_pos);
      }
      /* warn("%s %d pushing 2-length lua string %lx %lx", __FILE__, __LINE__, (long)s[0], (long)s[1]); */
      marpa_lua_pushlstring (L, s, (size_t)len);
    }
    return;
}

#define EXPECTED_LIBMARPA_MAJOR 8
#define EXPECTED_LIBMARPA_MINOR 6
#define EXPECTED_LIBMARPA_MICRO 0

#include "inspect_inc.c"
#include "kollos_inc.c"
#include "glue_inc.c"

MODULE = Marpa::R3        PACKAGE = Marpa::R3::Thin

PROTOTYPES: DISABLE

void
debug_level_set(new_level)
    int new_level;
PPCODE:
{
  /* TODO: Replace this function with Lua equivalent? */
  const int old_level = marpa_debug_level_set (new_level);
  if (old_level || new_level)
    marpa_r3_warn ("libmarpa debug level set to %d, was %d", new_level,
                   old_level);
  XSRETURN_YES;
}

void
error_names()
PPCODE:
{
  /* TODO: Replace this function with Lua equivalent? */
  int error_code;
  for (error_code = 0; error_code < MARPA_ERROR_COUNT; error_code++)
    {
      const char *error_name = marpa_error_description[error_code].name;
      XPUSHs (sv_2mortal (newSVpv (error_name, 0)));
    }
}

void
version()
PPCODE:
{
  /* TODO: Replace this function with Lua equivalent? */
    int version[3];
    int result = marpa_version(version);
    if (result < 0) { XSRETURN_UNDEF; }
    XPUSHs (sv_2mortal (newSViv (version[0])));
    XPUSHs (sv_2mortal (newSViv (version[1])));
    XPUSHs (sv_2mortal (newSViv (version[2])));
}

void
tag()
PPCODE:
{
  /* TODO: Replace this function with Lua equivalent? */
   const char* tag = _marpa_tag();
   XSRETURN_PV(tag);
}

MODULE = Marpa::R3            PACKAGE = Marpa::R3::Lua

void
new(class )
PPCODE:
{
    SV *new_sv;
    Marpa_Lua *lua_wrapper;
    int base_of_stack;
    lua_State *L;
    struct lua_extraspace *p_extra;
    int preload_ix;
    int package_ix;
    int loaded_ix;
    int glue_ix;
    int msghandler_ix;
    int status;

    Newx (lua_wrapper, 1, Marpa_Lua);

    L = marpa_luaL_newstate ();
    if (!L)
      {
          croak
              ("Marpa::R3 internal error: Lua interpreter failed to start");
      }

    base_of_stack = marpa_lua_gettop(L);

    /* Get lots of stack,
     * 1.) to avoid a lot of minor lua_pop()'s
     * 2.) to allow us to freely store things in fixed locations
     *     on the stack.
     */
    if (!marpa_lua_checkstack(L, 50))
    {
        croak ("Internal Marpa::R3 error; could not grow stack: " MYLUA_TAG);
    }

    marpa_lua_pushcfunction (L, glue_msghandler);
    msghandler_ix = marpa_lua_gettop(L);

    Newx( p_extra, 1, struct lua_extraspace);
    *(struct lua_extraspace **)marpa_lua_getextraspace(L) = p_extra;
    p_extra->ref_count = 1;

    marpa_luaL_openlibs (L);    /* open libraries */

    /* Get the preload table and leave it on the stack */
    marpa_lua_getglobal(L, "package");
    package_ix = marpa_lua_gettop(L);
    marpa_lua_getfield(L, package_ix, "preload");
    preload_ix = marpa_lua_gettop(L);
    marpa_lua_getfield(L, package_ix, "loaded");
    loaded_ix = marpa_lua_gettop(L);

    /* Set up preload of inspect package */
    if (marpa_luaL_loadbuffer(L, inspect_loader, inspect_loader_length, MYLUA_TAG)
      != LUA_OK) {
      const char* msg = marpa_lua_tostring(L, -1);
      croak(msg);
    }
    marpa_lua_setfield(L, preload_ix, "inspect");

    /* Set up preload of kollos metal package */
    marpa_lua_pushcfunction(L, kollos_metal_loader);
    marpa_lua_setfield(L, preload_ix, "kollos.metal");

    /* Set up preload of kollos package */
    if (marpa_luaL_loadbuffer(L, kollos_loader, kollos_loader_length, MYLUA_TAG)
      != LUA_OK) {
      const char* msg = marpa_lua_tostring(L, -1);
      croak(msg);
    }
    marpa_lua_setfield(L, preload_ix, "kollos");

    /* Actually load glue package
     * This will load the inspect, kollos.metal and kollos
     * packages.
     */
    if (marpa_luaL_loadbuffer(L, glue_loader, glue_loader_length, MYLUA_TAG)
      != LUA_OK) {
      const char* msg = marpa_lua_tostring(L, -1);
      croak(msg);
    }
    status = marpa_lua_pcall (L, 0, 1, msghandler_ix);
    if (status != 0) {
        const char *exception_string = handle_pcall_error (L, status);
        marpa_lua_settop (L, base_of_stack);
        croak (exception_string);
    }

    glue_ix = marpa_lua_gettop(L);
    marpa_lua_pushvalue(L, glue_ix);
    marpa_lua_setfield(L, loaded_ix, "glue");
    marpa_lua_pushvalue(L, glue_ix);
    marpa_lua_setglobal(L, "glue");

    /* create metatables */
    marpa_luaL_newmetatable(L, MT_NAME_SV);
    /* Lua stack: [mt] */
    /* register methods */
    marpa_luaL_setfuncs(L, glue_sv_meths, 0);

    marpa_lua_pushvalue(L, glue_ix);
    marpa_luaL_setfuncs(L, glue_funcs, 0);

    marpa_luaL_newlib(L, glue_sv_funcs);
    /* Lua stack: [ marpa_table, sv_table ] */
    marpa_lua_setfield (L, glue_ix, "sv");
    /* Lua stack: [ marpa_table ] */

    marpa_lua_settop (L, base_of_stack);
    /* Lua stack: [] */
    lua_wrapper->L = L;

    new_sv = sv_newmortal ();
    sv_setref_pv (new_sv, marpa_lua_class_name, (void *) lua_wrapper);
    XPUSHs (new_sv);
}

void
DESTROY( lua_wrapper )
    Marpa_Lua *lua_wrapper;
PPCODE:
{
  lua_refdec(lua_wrapper->L);
  Safefree (lua_wrapper);
}

void
call_by_tag( lua_wrapper, lua_ref, tag, codestr, signature, ... )
   Marpa_Lua* lua_wrapper;
   int lua_ref;
   const char* tag;
   const char* codestr;
   const char *signature;
PPCODE:
{
    const char * const error_tag = tag;

    /* 0 is never an acceptable index,
     * but this suppresses the GCC warning
     */
    int object_stack_ix = 0;

    const int first_optional_arg = 5;
    const int is_method = (lua_ref > 0);
    lua_State *const L = lua_wrapper->L;
    const int base_of_stack = marpa_lua_gettop (L);
    int msghandler_ix;
    int cache_ix;
    int top_after;
    int type;

    /* warn("%s %d is_method=%ld lua_ref=%ld", __FILE__, __LINE__,
       (long)is_method, (long)lua_ref); */

    marpa_luaL_checkstack(L, 30, "xlua EXEC_SIG_BODY");

    marpa_lua_pushcfunction(L, glue_msghandler);
    msghandler_ix = marpa_lua_gettop(L);

    if (lua_ref > 0) {
        marpa_lua_getglobal (L, "kollos");
        marpa_lua_getfield (L, -1, "registry");
        marpa_lua_rawgeti (L, -1, lua_ref);
        /* Lua stack: [ recce_table ] */
        object_stack_ix = marpa_lua_gettop (L);
    }

    marpa_lua_getglobal (L, "glue");
    marpa_lua_getfield (L, -1, "code_by_tag");
    cache_ix = marpa_lua_gettop(L);
    type = marpa_lua_getfield (L, cache_ix, tag);

    /*    warn("%s %d", __FILE__, __LINE__); */
    if (type != LUA_TFUNCTION) {

        const int status =
            marpa_luaL_loadbuffer (L, codestr, strlen (codestr), tag);
        if (status != 0) {
            const char *error_string = marpa_lua_tostring (L, -1);
            marpa_lua_pop (L, 1);
            croak ("Marpa::R3 error in call_by_tag(): %s\n", error_string);
        }
        marpa_lua_pushvalue (L, -1);
        marpa_lua_setfield (L, cache_ix, tag);
    }

    /* [ recce_table, function ] */

    {
        const int function_stack_ix = marpa_lua_gettop (L);
        int i, status;
        int arg_count;
        const int args_supplied = items - first_optional_arg;
        char default_return_sig[] = "*";
        const char* return_signature = default_return_sig;

        marpa_luaL_checkstack(L, items+20, "xlua EXEC_SIG_BODY");

        if (is_method) {
            /* first argument is table for object */
            marpa_lua_pushvalue (L, object_stack_ix);
            /* [ object_table, function, object_table ] */
        }

        /* the remaining arguments are those passed to the Perl call */
        for (i = 0; ; i++) {
            const char this_sig = signature[i];
            const int arg_ix = first_optional_arg + i;
            SV *arg_sv;

            switch (this_sig) {
            case '>':              /* end of arguments */
                return_signature = signature+i+1;
                goto endargs;
            case 0:              /* end of arguments */
                goto endargs;
            }

            if ((size_t)arg_ix >= (size_t)items) {
                croak
                    ("Internal error: signature ('%s') wants %ld items, but only %ld arguments in call_by_tag()",
                        signature, (long)(i + 1), (long)(items - first_optional_arg));
            }

            arg_sv = ST (arg_ix);
            coerce_to_lua(L, arg_sv, this_sig);
        }
      endargs:;

       /* warn("%s %d", __FILE__, __LINE__); */
       arg_count = marpa_lua_gettop(L) - function_stack_ix;

       if (arg_count - is_method != args_supplied) {
                croak
                    ("Internal error: signature ('%s') wants %ld items, but %ld arguments in call_by_tag()\n"
                        "    Problem was at %s\n",
                        signature, (long)(arg_count - is_method), (long)(args_supplied),
                        error_tag);
       }

        status = marpa_lua_pcall (L, arg_count, LUA_MULTRET, msghandler_ix);
        if (status != 0) {
            const char *exception_string = handle_pcall_error(L, status);
            marpa_lua_settop (L, base_of_stack);
            croak("%s\n", exception_string);
        }

        marpa_luaL_checkstack(L, 20, "xlua EXEC_SIG_BODY");
        
        top_after = marpa_lua_gettop (L);

        {
            /* check count of return values */
            int i;
            const int actual_return_count
              = top_after - function_stack_ix + 1;
            int desired_return_count = 0;
            int wanted_is_exact = 1;
            for (i = 0; ; i++) {
                const char this_sig = return_signature[i];
                if (!this_sig) break;
                if (!wanted_is_exact) {
                  /* If here, we've seen a '*', which has trailing
                   * signature items.
                   */
                  croak
                      ("Internal error: poorly formed return signature ('%s')", signature);
                }
                switch(this_sig) {
                case '*':
                     wanted_is_exact = 0;
                     break;
                case '-':
                case '0':
                case '1':
                case '2':
                     desired_return_count++;
                     break;
                default:
                    croak
                        ("Internal error: invalid return sig option '%c', signature=%s",
                        this_sig, signature);
                }
            }
            if (wanted_is_exact && actual_return_count > desired_return_count) {
                croak
                    ("Internal error; too many return items for signature ('%s'); actual=%ld; desired=%ld\n"
                        "    Problem was at %s\n",
                        signature, (long)actual_return_count, (long)desired_return_count,
                        error_tag
                        );
            }
            if (actual_return_count < desired_return_count) {
                croak
                    ("Internal error; too few return items for signature ('%s'); actual=%ld; desired=%ld\n"
                        "    Problem was at %s\n",
                        signature, (long)actual_return_count, (long)desired_return_count,
                        error_tag
                        );
            }
        }

        /* return args to caller */
        {
            SV *sv_result;
            int stack_ix;
            int signature_ix = 0;
            for (stack_ix = function_stack_ix;
                    stack_ix <= top_after;
                    stack_ix++) {
                const char this_sig = return_signature[signature_ix];
                switch (this_sig) {
                    case '*':
                        sv_result = coerce_to_sv (L, stack_ix, '-');
                        /* Took ownership of sv_result, we now need to mortalize it */
                        XPUSHs (sv_2mortal (sv_result));
                        break;
                    case '-':
                    case '0':
                    case '2':
                        sv_result = coerce_to_sv (L, stack_ix, this_sig);
                        /* Took ownership of sv_result, we now need to mortalize it */
                        XPUSHs (sv_2mortal (sv_result));
                        signature_ix++;
                        break;
                    default:
                        croak
                            ("Internal error: invalid return sig option %c in xlua EXEC_SIG_BODY",
                            this_sig);
                    case 0:
                        croak
                            ("Internal error: return sig too short ('%s') in xlua EXEC_SIG_BODY",
                            signature);
                }
            }
        }

        marpa_lua_settop (L, base_of_stack);
    }
}

void
exec( lua_wrapper, codestr, ... )
   Marpa_Lua* lua_wrapper;
   char* codestr;
PPCODE:
{
    const char * const error_tag = "Marpa::R3::Lua exec()";
    lua_State *const L = lua_wrapper->L;
    const int base_of_stack = marpa_lua_gettop (L);
    int arg_count;
    int msghandler_ix;
    int kollos_ix;

    marpa_lua_pushcfunction(L, glue_msghandler);
    msghandler_ix = marpa_lua_gettop(L);
    marpa_lua_getglobal (L, "kollos");
    kollos_ix = marpa_lua_gettop(L);

    {
        const int load_status = marpa_luaL_loadstring (L, codestr);
        if (load_status != 0) {
            /* The following is complex, because the error string
             * must be copied before it is removed from the Lua stack.
             * This is done with a Perl mortal SV.
             */
            const char *error_string = marpa_lua_tostring (L, -1);
            SV *temp_sv = sv_newmortal ();
            sv_setpvf (temp_sv, "Marpa::R3::Lua error in luaL_loadstring for %s: %s",
                error_tag, error_string);
            marpa_lua_settop (L, base_of_stack);
            croak ("%s", SvPV_nolen (temp_sv));
        }
    }

    /* At this point, the Lua function is on the top of the stack:
     * [func]
     * Set its first up value to the sandbox table.
     */
    marpa_lua_getfield (L, kollos_ix, "sandbox");
    if (!marpa_lua_setupvalue (L, -2, 1)) {
        marpa_lua_settop (L, base_of_stack);
        croak ("Marpa::R3::Lua error -- lua_setupvalue() failed");
    }
    /* [func] */

    {
        const int function_stack_ix = marpa_lua_gettop (L);
        int i, status;
        int top_after;

        marpa_luaL_checkstack(L, items+20, "xlua EXEC_BODY");

        /* the remaining arguments are those passed to the Perl call */
        for (i = 2; i < items; i++) {
            SV *arg_sv = ST (i);
            if (!SvOK (arg_sv)) {
                croak ("Marpa::R3::Lua::exec arg %d is not an SV", i);
            }
            MARPA_SV_SV (L, arg_sv);
        }

       arg_count = marpa_lua_gettop(L) - function_stack_ix;

        status = marpa_lua_pcall (L, arg_count, LUA_MULTRET, msghandler_ix);
        if (status != 0) {
            const char *exception_string = handle_pcall_error(L, status);
            marpa_lua_settop (L, base_of_stack);
            croak(exception_string);
        }

        marpa_luaL_checkstack(L, 20, "xlua EXEC_BODY");

        /* return args to caller */
        top_after = marpa_lua_gettop (L);
        for (i = function_stack_ix; i <= top_after; i++) {
            SV *sv_result = coerce_to_sv (L, i, '-');
            /* Took ownership of sv_result, we now need to mortalize it */
            XPUSHs (sv_2mortal (sv_result));
        }

        marpa_lua_settop (L, base_of_stack);
    }
}

BOOT:

    marpa_debug_handler_set(marpa_r3_warn);

    /* vim: set expandtab shiftwidth=2: */