/*
 * $Id: gsubrcperl.c,v 1.2 1998/12/09 03:17:39 jtr Exp $
 * $Source: /home/jtr/CVS/root/gsubrcperl/gsubrcperl.c,v $
 *
 * Perl gsubrc2: embeds a perl interpreter in gsub in order to allow
 * user-written message display code without forking a process
 * for each message.
 *
 * $Log: gsubrcperl.c,v $
 * Revision 1.2  1998/12/09 03:17:39  jtr
 * changes to shut up the compiler warnings (all perteaining to const
 * violations); changed gale includes to form #include <gale/...>
 *
 * Revision 1.1.1.1  1998/12/09 02:49:59  jtr
 * imported source from a July 1998 email message from Erik Ogan
 *
 */


#include <stdio.h>

/* Gale Includes */
#include <gale/gsubrc.h>

/* Perl Includes */
#include <EXTERN.h>
#include <perl.h>

#define SCRIPT  "./test.pl"

static PerlInterpreter *Perl = NULL;

/* Create a perl hash from a C environment */
void MakeEnvHash(HV *h, char **e);

/* DynaLoader setup */
extern void xs_init();

int gsubrc2 (char * const * const env, const char *msg,int len)
{
  char *args[3] = { "", SCRIPT, NULL};
  char **e = (char **) env;
  char *fn = NULL;
  int ret = 0;

  /* declare Perl stack pointer (sp) */
  dSP;

  /* Hash Table for "env" */
  static HV *penv = NULL;

  /* Reference to penv */
  static SV *penv_r = NULL;

    if (!Perl)
      {
        /* First time through... */
        
        Perl = perl_alloc();

        perl_construct(Perl);

        /* Well, for the first time, actually... */
        SPAGAIN ;
        
        perl_destruct_level = 1;

        /* Let's find the perl script.. */
        while (*e)
          {
            if ( !strncmp(*e, "GALE_GSUBRCPERL", 15) )
              {
                fn=(*e)+16;
                break;
              }
            e++;
          }
        
        if (!fn)
          {
            fprintf(stderr, "gsubrc.so: GALE_GSUBRCPERL not set! I can't "
                            "find your file! (Exiting)\n");
            exit(245);
          }

        args[1] = fn;
        
        /*
         * Second argument is a function pointer to set up DynaLoader,
         * see the (end of the) perlembed(l) manpage for details on
         * how to automatically generate this function. (Not that I've
         * gotten it to work...)
         */
        if (ret = perl_parse(Perl, xs_init, 2, args, (char **)NULL))
          {
            fprintf(stderr, "gsubrc.so: perl_parse failed: %d.\n(Exiting)\n",
                    ret);
            exit( ret);
          }

        /* Good for setup: constructors, destructors, etc... */
        perl_run(Perl);

        penv = newHV();
        penv_r = newRV_noinc((SV*)penv);
      }
    else
      { 
        /* Clear out the old hash table */
        hv_clear(penv);
      }

    MakeEnvHash(penv, (char **)env);
    
    {
      char *msg2= strdup(msg);
      ENTER;
      SAVETMPS;

      PUSHMARK(sp);
      XPUSHs(sv_2mortal(newSVpv(msg2,len)));
      XPUSHs(penv_r);     /* don't mortalize here */
      PUTBACK;

      /* G_EVAL   : very important! if perl script exits, gsub exits...
G_SCALAR : Call subroutine in a scalar context                 */
      ret = perl_call_pv("gsubrc", G_SCALAR | G_EVAL);

      /* Eval tried to exit...ACK! */
      if (SvTRUE(GvSV(errgv)))
          fprintf(stderr,
                  "gsubrc.so: eval error: %s\n", SvPVx(GvSV(errgv), na));

      /* ret == # items returned */
      if (ret != 1)
      {
          fprintf(stderr, "gsubrc.so: Perl gsubrc failed!\n");
          ret = 255;
      }
      else
      {
          /* Pop off an int */
          ret = POPi;
      }

      FREETMPS;
      LEAVE;

      free(msg2);
    }

    return(ret);
}

void MakeEnvHash(HV *h, char **e)
{
  char *eq;
  
  while (*e)
    {
      eq = strchr(*e,'=');
      if (eq)
        /* Mmmm, pointer arithmetic */
        hv_store(h,*e,eq-*e,sv_2mortal(newSVpv(eq+1,0)),0);
      
      ++e;
    }
}