/* ====================================================================
 * Copyright 1999 Web Juice, LLC. All rights reserved.
 *
 * perl_tags.c
 *
 * These are the C functions which bridge the gap between the C template
 * extensions and perl template extensions.
 *
 * ==================================================================== */

#include <stdio.h>

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

#include <context.h>
#include <template.h>

#include "ppport.h"

#include "perl_tags.h"


/* ====================================================================
 * NAME:          perl_simple_tag
 *
 * DESCRIPTION:   The tag function for perl simple tags.
 *
 * RETURN VALUES: None.
 *
 * BUGS:          Hopefully none.
 * ==================================================================== */
void
perl_simple_tag(context_p ctx, char **output, int argc, char **argv)
{
    HV *perl_simple_tags = perl_get_hv(PERL_TAGS_SIMPLE_TAG_HASH, TRUE);
    SV **coderef         = NULL;
    SV *perlcontext      = sv_newmortal();
    SV *tc               = sv_newmortal();
    int i, retval;
    char key[20];
    dSP;
    CV *code;

    /* Build the unique key for this context */
    snprintf(key, 20, "%p", context_root(ctx));

    /* Create and bless a perl version of the context */
    sv_magic(tc, sv_2mortal(newSViv((IV)ctx)), '~', NULL, 0);
    perlcontext = sv_bless(newRV(tc), gv_stashpv(TEMPLATE_PACKAGE, 0));

    /* Fetch a code reference out of the perl_simple_tags hash */
    if (hv_exists(perl_simple_tags, key, strlen(key)))
    {
        HV *stags = (HV *)SvRV(*(hv_fetch(perl_simple_tags,
                                          key, strlen(key), FALSE)));
        coderef = hv_fetch(stags, argv[0], strlen(argv[0]), FALSE);
    }
    else
    {
        *output = NULL;
	return;
    }
    if (coderef == NULL)
    {
        *output = NULL;
        return;
    }
    code = (CV *)*coderef;

    ENTER;
    SAVETMPS;


    /* push arguments */
    PUSHMARK(sp);
    /* first the context */
    XPUSHs(perlcontext);
    for (i = 0; i <= argc; i++)
    {
        if (argv[i] != NULL)
        {
            XPUSHs(sv_2mortal(newSVpv(argv[i], strlen(argv[i]))));
        }
        else
        {
            XPUSHs(&PL_sv_undef);
        }
    }

    PUTBACK;

    retval = perl_call_sv((SV *)code, G_SCALAR);

    SPAGAIN;

    /* Translate the return into a char* for parser */
    if (retval == 1)
    {
        SV *s = POPs;

        if (! SvPOK(s)) {
            *output = NULL;
        } else {
            char *t = SvPVX(s);

            *output = (char *)malloc(strlen(t) + 1);
            strncpy(*output, t, strlen(t));
            (*output)[strlen(t)] = '\0';
        }
    }
    else
    {
        *output = NULL;
    }

    PUTBACK;
    FREETMPS;
    LEAVE;

    return;
}



/* ====================================================================
 * NAME:          perl_tag_pair
 *
 * DESCRIPTION:   The tag pair function for perl tag pairs.
 *
 * RETURN VALUES: None.
 *
 * BUGS:          Hopefully none.
 * ==================================================================== */
void
perl_tag_pair(context_p ctx, int argc, char **argv)
{
    HV *perl_tag_pairs = perl_get_hv(PERL_TAGS_TAG_PAIR_HASH, TRUE);
    SV **coderef       = NULL;
    SV *perlcontext    = sv_newmortal();
    SV *tc             = sv_newmortal();
    int i;
    char key[20];
    dSP;
    CV *code;

    /* Build the unique key for this context */
    snprintf(key, 20, "%p", context_root(ctx));


    /* Create and bless a perl version of the context */
    sv_magic(tc, sv_2mortal(newSViv((IV)ctx)), '~', NULL, 0);
    perlcontext = sv_bless(newRV(tc), gv_stashpv(TEMPLATE_PACKAGE, 0));


    /* Fetch a code reference out of the perl_tag_pairs hash */
    if (hv_exists(perl_tag_pairs, key, strlen(key)))
    {
        HV *tagps = (HV *)SvRV(*(hv_fetch(perl_tag_pairs, key, strlen(key),
                                          FALSE)));
        coderef = hv_fetch(tagps, argv[0], strlen(argv[0]), FALSE);
    }
    else
    {
        return;
    }
    if (coderef == NULL)
    {
        return;
    }
    code = (CV *)*coderef;


    ENTER;
    SAVETMPS;


    /* push arguments */
    PUSHMARK(sp);
    /* first the context */
    XPUSHs(perlcontext);
    for (i = 0; i <= argc; i++)
    {
        if (argv[i] != NULL)
        {
            XPUSHs(sv_2mortal(newSVpv(argv[i], strlen(argv[i]))));
        }
        else
        {
            XPUSHs(&PL_sv_undef);
        }
    }

    PUTBACK;

    perl_call_sv((SV *)code, G_DISCARD);

    SPAGAIN;
    PUTBACK;
    FREETMPS;
    LEAVE;

    return;
}