plu_table.c

#include "plu_table.h"

#include "plu_debug.h"
#include "plu_lua.h"

plu_table_t *
plu_new_table_object(pTHX_ lua_State *ls)
{
  plu_table_t *t;
  int tblid;
  PLU_dSTACKASSERT;
  PLU_ENTER_STACKASSERT(ls);

  tblid = luaL_ref(ls, LUA_REGISTRYINDEX);

  Newx(t, 1, plu_table_t);
  t->L = ls;
  t->registry_index = tblid;

  PLU_LEAVE_STACKASSERT_MODIFIED(ls, -1);
  return t;
}

SV *
plu_new_table_object_perl(pTHX_ lua_State *L)
{
  SV *sv;
  PLU_dSTACKASSERT;
  PLU_ENTER_STACKASSERT(L);
  plu_table_t *tbl = plu_new_table_object(aTHX_ L);
  sv = newSV(0);
  sv_setref_pv( sv, "PLua::Table", (void*)tbl );
  PLU_LEAVE_STACKASSERT_MODIFIED(L, -1);
  return sv;
}

HV *
plu_table_obj_to_hash(pTHX_ plu_table_t *THIS, int recursive)
{
  PLU_dSTACKASSERT;
  int table_stack_offset;
  lua_State *L;
  char *keystr;
  size_t keylen;
  char tmp[32];
  SV *value_sv;
  int dopop;
  HV *RETVAL;

  L = THIS->L;
  PLU_ENTER_STACKASSERT(L);
  PLU_TABLE_PUSH_TO_STACK(*THIS);

  RETVAL = newHV();
  sv_2mortal((SV *)RETVAL);
  table_stack_offset = lua_gettop(L);

  lua_pushnil(L);  /* first key */
  while (lua_next(L, table_stack_offset) != 0) {
    /* uses 'key' (at index -2) and 'value' (at index -1) */

    /* Prepare key */
    switch (lua_type(L, -2)) {
    case LUA_TSTRING:
      keystr = (char *)lua_tolstring(L, -2, &keylen);
      break;
    case LUA_TNUMBER:
    case LUA_TBOOLEAN:
    {
      lua_Number n = lua_tonumber(L, -2);
      sprintf(tmp, LUA_NUMBER_FMT, n);
      keylen = strlen(tmp);
      keystr = &tmp[0];
      break;
    }
    default:
      croak("Unsupported Lua type '%s' for Perl hash keys", lua_typename(L, lua_type(L, 02)));
    }

    /* Prepare value */
    value_sv = plu_luaval_to_perl(aTHX_ L, -1, &dopop);
    if (recursive && SvROK(value_sv)
        && sv_derived_from(value_sv, "PLua::Table"))
    {
      HV *tmph;
      tmph = plu_table_obj_to_hash(aTHX_ (plu_table_t *)SvIV(SvRV(value_sv)), recursive);
      SvREFCNT_dec(value_sv);
      value_sv = newRV_inc((SV *)tmph);
    }

    (void)hv_store(RETVAL, keystr, keylen, value_sv, 0);

    /* removes 'value' if not already done; keeps 'key' for next iteration */
    if (dopop)
      lua_pop(L, 1);
  }
  lua_pop(L, 1);

  PLU_LEAVE_STACKASSERT(L);

  return RETVAL;
}


AV *
plu_table_obj_to_array(pTHX_ plu_table_t *THIS, int recursive)
{
  PLU_dSTACKASSERT;
  int table_stack_offset;
  lua_State *L;
  char *keystr;
  size_t keylen;
  SV *value_sv;
  int dopop;
  AV *RETVAL;
  I32 aryidx;

  L = THIS->L;
  PLU_ENTER_STACKASSERT(L);
  PLU_TABLE_PUSH_TO_STACK(*THIS);

  RETVAL = newAV();
  sv_2mortal((SV *)RETVAL);
  table_stack_offset = lua_gettop(L);

  lua_pushnil(L);  /* first key */
  while (lua_next(L, table_stack_offset) != 0) {
    /* uses 'key' (at index -2) and 'value' (at index -1) */

    /* Prepare key - cast to int if need be */
    switch (lua_type(L, -2)) {
    case LUA_TSTRING:
    {
      SV *tmpsv;
      keystr = (char *)lua_tolstring(L, -2, &keylen);
      /* Using SV is not efficient, but may cause the perl warnings we want.
       * That in turn may cause Perl code to be run that can throw exceptions.
       * So we need to mortalize. Grmpf. */
      tmpsv = newSVpvn(keystr, (STRLEN)keylen);
      sv_2mortal(tmpsv);
      aryidx = (I32)SvIV(tmpsv);
      SvREFCNT_dec(tmpsv);
      break;
    }
    case LUA_TNUMBER:
    {
      lua_Number n = lua_tonumber(L, -2); /* Don't change its type with lua_tointeger! */
      aryidx = (I32)n; /* FIXME should this warn for actual truncation? */
      break;
    }
    case LUA_TBOOLEAN:
      aryidx = lua_toboolean(L, -2);
      break;
    default:
      croak("Unsupported Lua type '%s' for Perl array indexes", lua_typename(L, lua_type(L, 02)));
    }

    /* Prepare value */
    value_sv = plu_luaval_to_perl(aTHX_ L, -1, &dopop);
    if (recursive && SvROK(value_sv)
        && sv_derived_from(value_sv, "PLua::Table"))
    {
      AV *tmpa;
      tmpa = plu_table_obj_to_array(aTHX_ (plu_table_t *)SvIV(SvRV(value_sv)), recursive);
      SvREFCNT_dec(value_sv);
      value_sv = newRV_inc((SV *)tmpa);
    }

    (void)av_store(RETVAL, aryidx, value_sv);

    /* removes 'value' if not already done; keeps 'key' for next iteration */
    if (dopop)
      lua_pop(L, 1);
  }
  lua_pop(L, 1);

  PLU_LEAVE_STACKASSERT(L);

  return RETVAL;
}


AV *
plu_table_obj_to_keys_array(pTHX_ plu_table_t *THIS)
{
  PLU_dSTACKASSERT;
  int table_stack_offset;
  lua_State *L;
  SV *sv;
  AV *RETVAL;

  L = THIS->L;
  PLU_ENTER_STACKASSERT(L);
  PLU_TABLE_PUSH_TO_STACK(*THIS);

  RETVAL = newAV();
  sv_2mortal((SV *)RETVAL);
  table_stack_offset = lua_gettop(L);

  lua_pushnil(L);  /* first key */
  while (lua_next(L, table_stack_offset) != 0) {
    /* uses 'key' (at index -2) and 'value' (at index -1) */
    lua_pop(L, 1);
    sv = plu_luaval_to_perl_safe(aTHX_ L, -1); /* need safe version to keep key for next iter */
    av_push(RETVAL, sv);
  }
  lua_pop(L, 1);

  PLU_LEAVE_STACKASSERT(L);

  return RETVAL;
}


AV *
plu_table_obj_to_values_array(pTHX_ plu_table_t *THIS)
{
  PLU_dSTACKASSERT;
  int table_stack_offset;
  lua_State *L;
  SV *sv;
  AV *RETVAL;
  int dopop;

  L = THIS->L;
  PLU_ENTER_STACKASSERT(L);
  PLU_TABLE_PUSH_TO_STACK(*THIS);

  RETVAL = newAV();
  sv_2mortal((SV *)RETVAL);
  table_stack_offset = lua_gettop(L);

  lua_pushnil(L);  /* first key */
  while (lua_next(L, table_stack_offset) != 0) {
    /* uses 'key' (at index -2) and 'value' (at index -1) */
    sv = plu_luaval_to_perl(aTHX_ L, -1, &dopop);
    av_push(RETVAL, sv);
    if (LIKELY( dopop ))
      lua_pop(L, 1);
  }
  lua_pop(L, 1);

  PLU_LEAVE_STACKASSERT(L);

  return RETVAL;
}