/* modperl.c: -*- C -*-  Include Perl in your Meta-HTML program? */

/*  Copyright (c) 1997 Brian J. Fox
    Author: Brian J. Fox (bfox@ai.mit.edu) Tue Jun 17 22:02:50 1997.

    Original design by Jesse Glick (jesse@sig.bsh.com)

    This file is part of <Meta-HTML>(tm), a system for the rapid
    deployment of Internet and Intranet applications via the use of
    the Meta-HTML language.

    Copyright (c) 1995, 1996, Brian J. Fox (bfox@ai.mit.edu).
    Copyright (c) 1996, Universal Access Inc. (http://www.ua.com).

    Meta-HTML is free software; you can redistribute it and/or modify
    it under the terms of the UAI Free Software License as published
    by Universal Access Inc.; either version 1, or (at your option) any
    later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    UAI Free Software License for more details.

    You should have received a copy of the UAI Free Software License
    along with this program; if you have not, you may obtain one by
    writing to:

    Universal Access Inc.
    129 El Paseo Court
    Santa Barbara, CA
    93101  */

#include "language.h"
#define bool int
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

extern void boot_DynaLoader (CV* cv);
XS (XD_main_mhtml);

static void pf_perl_eval (PFunArgs);

static PFunDesc functab[] =
{
  /*   tag	     complex? debug_level	   code    */
  { "PERL-EVAL",	0,	 0,		pf_perl_eval },
  { (char *)NULL,	0,	 0,		(PFunHandler *)NULL }
};

/* 3) Write the function which installs the commands, and performs any other
      module specific initializations.  This function is called exactly once.*/
void
module_initialize (void)
{
  register int i;
  Symbol *sym;

  /* Install the names and pointers. */
  for (i = 0; functab[i].tag != (char *)NULL; i++)
    {
      sym = symbol_intern_in_package (mhtml_function_package, functab[i].tag);
      sym->type = symtype_FUNCTION;
      sym->values = (char **)(&functab[i]);
    }
}

void _init (void) { module_initialize (); }

static PerlInterpreter *perl_interpreter;
static int perl_initialized = 0;

static void
destroy_perl (void)
{
  perl_destruct (perl_interpreter);
  perl_free (perl_interpreter);
}

/* XSUB interface to MetaHTML direct-evaluation facility.
   Inspired by a version generated by xsubpp. */
XS(XS_main_mhtml)
{
  dXSARGS;
  if (items != 1)
    croak("Usage: mhtml $string");
  {
    char *mhtml_string = (char *) SvPV (ST (0), na);
    char *RETVAL = mhtml_evaluate_string (mhtml_string);
    ST(0) = sv_newmortal ();
    sv_setpv ((SV*) ST (0), RETVAL);
  }
  XSRETURN (1);
}

static void
xs_init (void)
{
  newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
  newXSproto ("main::mhtml", XS_main_mhtml, __FILE__, "$");
}

static void
init_perl (void)
{
  /* Is there any way to pass on the real execution environment? */
  char *env[]= {(char *)NULL};
  char *argv[4]={
    (char *)NULL,
    "-e",
    "package main; sub __eval_from_mhtml__($;) {my $__result__=eval $_[0]; (\"$__result__\", \"$@\")}",
    (char *)NULL
  };

  if (!perl_initialized)
    {
      perl_initialized++;
      perl_interpreter = perl_alloc ();
      perl_construct (perl_interpreter);
      perl_parse (perl_interpreter, xs_init, 3, argv, env);
      perl_run (perl_interpreter);
      atexit (destroy_perl);
    }
}

static void
perl_eval (char *code, char **output, char **errors)
{
  *output = (char *)NULL;
  *errors = (char *)NULL;

  init_perl ();
  {
    dSP;
    ENTER;
    SAVETMPS;
    PUSHMARK (sp);
    XPUSHs (sv_2mortal(newSVpv(code, 0)));
    PUTBACK;
    if (perl_call_pv ("main::__eval_from_mhtml__", G_ARRAY | G_EVAL) != 2)
      {
	page_syserr ("PERL: Got wrong output count for: %s", code);
	return;
      }
    SPAGAIN;
    *errors = strdup (POPp);
    *output = strdup(POPp);
    PUTBACK;
    FREETMPS;
    LEAVE;
  }
}

/* <perl "perl code...">

   Evaluates the Perl code in a scalar context and returns the result
   as a string. If there is an error, sends it to page debugging log;
   if you need to do something else with errors, eval {} your code
   yourself! */

static void
pf_perl_eval (PFunArgs)
{
  char *code = mhtml_evaluate_string (get_positional_arg (vars, 0));

  if (!empty_string_p (code))
    {
      char *output, *errors;

      perl_eval (code, &output, &errors);

      if (output != (char *)NULL)
	{
	  bprintf_insert (page, start, "%s", output);
	  *newstart += strlen (output);
	  free (output);
	}

      if (!empty_string_p (errors))
	page_debug ("Errors from PERL: %s", errors);

      xfree (errors);
    }
  xfree (code);
}
