/*
Copyright (C) 2006-2007, The Perl Foundation.
$Id: lua.pmc 21554 2007-09-25 13:55:52Z paultcochrane $

=head1 NAME

pmc/lua.pmc - Lua native runtime

=head1 DESCRIPTION

This singleton PMC holds some static methods.

=head2 Methods

=over 4

=cut

*/

#include "lua_private.h"
#include <locale.h>

INTVAL dynpmc_LuaBoolean;
INTVAL dynpmc_LuaClosure;
INTVAL dynpmc_LuaFunction;
INTVAL dynpmc_LuaNil;
INTVAL dynpmc_LuaNumber;
INTVAL dynpmc_LuaString;
INTVAL dynpmc_LuaTable;
INTVAL dynpmc_LuaUserdata;

static PMC * Lua_PMC;

static STRING*
context_infostr(PARROT_INTERP, parrot_context_t *ctx)
{
    struct Parrot_Context_info info;
    STRING *res = NULL;

    Parrot_block_DOD(interp);
    if (Parrot_Context_get_info(interp, ctx, &info)) {
        char *file = info.file;
        res = Parrot_sprintf_c(interp, "\t%s:%d in function '%Ss'\n",
                                       file, info.line, info.subname);

        /* free the non-constant string, but not the constant one */
        if (strncmp("(unknown file)", file, 14) < 0)
            string_cstring_free(file);
    }
    Parrot_unblock_DOD(interp);

    return res;
}


pmclass Lua
    singleton
    dynpmc
    group lua_group {

/*
* Class initialization.
*/
    void class_init() {
        if (pass) {
            dynpmc_LuaBoolean = pmc_type(INTERP,
              const_string(INTERP, "LuaBoolean"));
            dynpmc_LuaClosure = pmc_type(INTERP,
              const_string(INTERP, "LuaClosure"));
            dynpmc_LuaFunction = pmc_type(INTERP,
              const_string(INTERP, "LuaFunction"));
            dynpmc_LuaNil = pmc_type(INTERP,
              const_string(INTERP, "LuaNil"));
            dynpmc_LuaNumber = pmc_type(INTERP,
              const_string(INTERP, "LuaNumber"));
            dynpmc_LuaString = pmc_type(INTERP,
              const_string(INTERP, "LuaString"));
            dynpmc_LuaTable = pmc_type(INTERP,
              const_string(INTERP, "LuaTable"));
            dynpmc_LuaUserdata = pmc_type(INTERP,
              const_string(INTERP, "LuaUserdata"));
        }
    }

/*

=item C<void* get_pointer()>

=item C<void set_pointer(void *ptr)>

These two functions are part of the singleton creation interface. For more
information see F<src/pmc.c>.

=cut

*/
    void* get_pointer() {
        return Lua_PMC;
    }

    void set_pointer(void* ptr) {
        Lua_PMC = (PMC*) ptr;
    }

/*

=item C<STRING* caller()>

=cut

*/
    METHOD STRING* caller() {
        parrot_context_t *ctx = CONTEXT(INTERP->ctx);

        /* backtrace: follow the continuation chain */
        while (1) {
            PMC *cont;
            if (PMC_metadata(ctx->current_sub) != NULL) {
                struct Parrot_Context_info info;
                Parrot_block_DOD(INTERP);
                if (Parrot_Context_get_info(INTERP, ctx, &info)) {
                    /* free the non-constant string, but not the constant one */
                    if (strncmp("(unknown file)", info.file, 14) < 0)
                        string_cstring_free(info.file);

                    Parrot_unblock_DOD(INTERP);
                    return info.subname;
                }
                Parrot_unblock_DOD(INTERP);
                break;
            }

            cont = ctx->current_cont;
            if (!cont)
                break;
            ctx = PMC_cont(cont)->to_ctx;
            if (!ctx)
                break;
        }

        return const_string(INTERP, "?");
    }

/*

=item C<PMC* clock()>

=cut

*/
    METHOD PMC* clock() {
        PMC *retval = pmc_new(INTERP, dynpmc_LuaNumber);
        FLOATVAL f = ((FLOATVAL)clock())/(FLOATVAL)CLOCKS_PER_SEC;
        VTABLE_set_number_native(INTERP, retval, f);
        return retval;
    }

/*

=item C<PMC* frexp(PMC* x)>

=cut

*/
    METHOD PMC* frexp(PMC* x) {
        PMC *y;
        PMC *expn;
        PMC *retval;
        int e;

        y = pmc_new(INTERP, dynpmc_LuaNumber);
        expn = pmc_new(INTERP, dynpmc_LuaNumber);
        VTABLE_set_number_native(INTERP, y,
                                 frexp(VTABLE_get_number(INTERP, x), &e));
        VTABLE_set_integer_native(INTERP, expn, e);
        retval = pmc_new(INTERP, enum_class_Array);
        VTABLE_set_integer_native(INTERP, retval, 2);
        VTABLE_set_pmc_keyed_int(INTERP, retval, 0, y);
        VTABLE_set_pmc_keyed_int(INTERP, retval, 1, expn);
        return retval;
    }

/*

=item C<PMC* ldexp(PMC* x, PMC* expn)>

=cut

*/
    METHOD PMC* ldexp(PMC* x, PMC* expn) {
        PMC *retval = pmc_new(INTERP, dynpmc_LuaNumber);
        VTABLE_set_number_native(INTERP, retval,
                                 ldexp(VTABLE_get_number(INTERP, x),
                                       VTABLE_get_integer(INTERP, expn)));
        return retval;
    }

/*

=item C<PMC* mktime(PMC* tm)>

=cut

*/
    METHOD PMC* mktime(PMC* tm) {
        PMC *retval;
        time_t t;
        struct tm ts;
        ts.tm_sec = VTABLE_get_integer_keyed_int(INTERP, tm, 0);
        ts.tm_min = VTABLE_get_integer_keyed_int(INTERP, tm, 1);
        ts.tm_hour = VTABLE_get_integer_keyed_int(INTERP, tm, 2);
        ts.tm_mday = VTABLE_get_integer_keyed_int(INTERP, tm, 3);
        ts.tm_mon = VTABLE_get_integer_keyed_int(INTERP, tm, 4);
        ts.tm_year = VTABLE_get_integer_keyed_int(INTERP, tm, 5);
        ts.tm_isdst = VTABLE_get_integer_keyed_int(INTERP, tm, 8);
        t = mktime(&ts);
        if (t == -1) {
            retval = pmc_new(INTERP, dynpmc_LuaNil);
        }
        else {
            retval = pmc_new(INTERP, dynpmc_LuaNumber);
            VTABLE_set_integer_native(INTERP, retval, t);
        }
        return retval;
    }

/*

=item C<PMC* modf(PMC* x)>

=cut

*/
    METHOD PMC* modf(PMC* x) {
        PMC *y;
        PMC *d;
        PMC *retval;
        FLOATVAL _d;

        y = pmc_new(INTERP, dynpmc_LuaNumber);
        d = pmc_new(INTERP, dynpmc_LuaNumber);
        VTABLE_set_number_native(INTERP, y,
                                 modf(VTABLE_get_number(INTERP, x), &_d));
        VTABLE_set_number_native(INTERP, d, _d);
        retval = pmc_new(INTERP, enum_class_Array);
        VTABLE_set_integer_native(INTERP, retval, 2);
        VTABLE_set_pmc_keyed_int(INTERP, retval, 0, d);
        VTABLE_set_pmc_keyed_int(INTERP, retval, 1, y);
        return retval;
    }

/*

=item C<PMC* setlocale(INTVAL category, STRING* locale)>

=cut

*/
    METHOD PMC* setlocale(INTVAL category, STRING* locale) {
        PMC *retval;
        static const int cat[] = {
            LC_ALL, LC_COLLATE, LC_CTYPE, LC_MONETARY, LC_NUMERIC, LC_TIME
        };
        char *loc = (locale != NULL) ? string_to_cstring(INTERP, locale) : NULL;
        char *p = setlocale(cat[category], loc);
        if (p == NULL) {
            retval = pmc_new(INTERP, dynpmc_LuaNil);
        }
        else {
            retval = pmc_new(INTERP, dynpmc_LuaString);
            VTABLE_set_string_native(INTERP, retval,
                                     string_from_cstring(INTERP, p, 0));
        }
        return retval;
    }

/*

=item C<STRING* strftime(STRING* fmt, PMC* tm)>

=cut

*/
    METHOD STRING* strftime(STRING* fmt, PMC* tm) {
        struct tm stm;
        char b[200];
        size_t reslen;
        const char *s = string_to_cstring(INTERP, fmt);

        stm.tm_sec   = VTABLE_get_integer_keyed_int(INTERP, tm, 0);
        stm.tm_min   = VTABLE_get_integer_keyed_int(INTERP, tm, 1);
        stm.tm_hour  = VTABLE_get_integer_keyed_int(INTERP, tm, 2);
        stm.tm_mday  = VTABLE_get_integer_keyed_int(INTERP, tm, 3);
        stm.tm_mon   = VTABLE_get_integer_keyed_int(INTERP, tm, 4) - 1;
        stm.tm_year  = VTABLE_get_integer_keyed_int(INTERP, tm, 5) - 1900;
        stm.tm_wday  = VTABLE_get_integer_keyed_int(INTERP, tm, 6);
        stm.tm_yday  = VTABLE_get_integer_keyed_int(INTERP, tm, 7);
        stm.tm_isdst = VTABLE_get_integer_keyed_int(INTERP, tm, 8);

        reslen = strftime(b, sizeof b, s, &stm);
        return string_from_cstring(INTERP, b, reslen);
    }

/*

=item C<STRING* tmpname()>

=cut

*/
    METHOD STRING* tmpname() {
        char buff[32];
        int e;
#ifdef WIN32
        e = (tmpnam(buff) == NULL);
#else
        strcpy(buff, "/tmp/lua_XXXXXX");
        e = mkstemp(buff);
        if (e != -1) close(e);
        e = (e == -1);
#endif
        if (e) {
            real_exception(INTERP, NULL, 1,
                           "unable to generate a unique filename");
            return NULL;
        }
        return string_from_cstring(INTERP, buff, 0);
    }

/*

=item C<STRING* traceback(INTVAL level)>

=cut

*/
    METHOD STRING* traceback(INTVAL level) {
        STRING *bt;
        STRING *str;
        parrot_context_t *ctx;

        bt = string_from_literal(INTERP, "stack traceback:\n");
        /* information about the current sub */
        ctx = CONTEXT(INTERP->ctx);

        if (level == 0) {
            str = context_infostr(INTERP, ctx);
            bt = string_append(INTERP, bt, str);
        }

        /* backtrace: follow the continuation chain */
        while (1) {
            PMC *cont = ctx->current_cont;
            if (!cont)
                break;
            ctx = PMC_cont(cont)->to_ctx;
            if (!ctx)
                break;

            str = context_infostr(INTERP, ctx);
            if (!str)
                break;
            bt = string_append(INTERP, bt, str);
        }

        return bt;
    }

/*

=item C<STRING* where()>

=cut

*/
    METHOD STRING* where() {
        parrot_context_t *ctx = CONTEXT(INTERP->ctx);

        /* backtrace: follow the continuation chain */
        while (1) {
            PMC *cont;
            PMC *sub = ctx->current_sub;
            if (PMC_metadata(sub) != NULL
              && VTABLE_isa(INTERP, sub, const_string(INTERP, "LuaClosure"))) {
                struct Parrot_Context_info info;
                Parrot_block_DOD(INTERP);
                if (Parrot_Context_get_info(INTERP, ctx, &info)) {
                    STRING* res = Parrot_sprintf_c(INTERP, "%s:%d:",
                                                   info.file, info.line);
                    /* free the non-constant string, but not the constant one */
                    if (strncmp("(unknown file)", info.file, 14) < 0)
                        string_cstring_free(info.file);

                    Parrot_unblock_DOD(INTERP);
                    return res;
                }
                Parrot_unblock_DOD(INTERP);
                break;
            }

            cont = ctx->current_cont;
            if (!cont)
                break;
            ctx = PMC_cont(cont)->to_ctx;
            if (!ctx)
                break;
        }

        return const_string(INTERP, "_._:0:");
    }

}

/*

=back

=head1 AUTHORS

Francois Perrad

=cut

*/

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */