/***********************************************************************
*
* embperl.c
*
* Routines for manipulating embedded Perl interpreter
*
* Copyright (C) 2003 by Roaring Penguin Software Inc.
*
***********************************************************************/

static char const RCSID[] =
"$Id: embperl.c,v 1.12 2004/11/25 13:40:40 dfs Exp $";

#ifdef EMBED_PERL
#include <EXTERN.h>
#include <perl.h>
#include <errno.h>
#include <syslog.h>

static PerlInterpreter *my_perl = NULL;
extern void xs_init ();

/**********************************************************************
* %FUNCTION: num_open_descriptors
* %ARGUMENTS:
*  None
* %RETURNS:
*  An estimate of the number of open file descriptors.
* %DESCRIPTION:
*  This is a truly evil function.
***********************************************************************/
static int
num_open_descriptors(void)
{
    int i, total;
    total = 0;
    for (i=0; i<1024; i++) {
	if (fcntl(i, F_GETFL, 0) != -1) total++;
    }
    return total;
}

int
make_embedded_interpreter(char const *progPath,
			  char const *subFilter,
			  int wantStatusReports)
{
    char *argv[6];
    int argc;
    int descriptors;

    if (my_perl != NULL) {
#ifdef SAFE_EMBED_PERL
	PL_perl_destruct_level = 1;
	perl_destruct(my_perl);
	perl_free(my_perl);
	my_perl = NULL;
#else
	syslog(LOG_WARNING, "Cannot destroy and recreate a Perl interpreter safely on this platform.  Filter rules will NOT be reread.");
	return 0;
#endif

    }

    my_perl = perl_alloc();
    if (!my_perl) {
	errno = ENOMEM;
	return -1;
    }
#ifdef PERL_SET_CONTEXT
    PERL_SET_CONTEXT(my_perl);
#endif
    PL_perl_destruct_level = 1;
    perl_construct(my_perl);
    if (subFilter) {
	argv[0] = "";
	argv[1] = (char *) progPath;
	argv[2] = "-f";
	argv[3] = (char *) subFilter;
	if (wantStatusReports) {
	    argv[4] = "-embserveru";
	} else {
	    argv[4] = "-embserver";
	}
	argv[5] = NULL;
	argc = 5;
    } else {
	argv[0] = "";
	argv[1] = (char *) progPath;
	if (wantStatusReports) {
	    argv[2] = "-embserveru";
	} else {
	    argv[2] = "-embserver";
	}
	argv[3] = NULL;
	argc = 3;
    }
    descriptors = num_open_descriptors();
    perl_parse(my_perl, xs_init, argc, argv, NULL);
    perl_run(my_perl);
    if (num_open_descriptors() > descriptors) {
	syslog(LOG_INFO, "WARNING: Something in your Perl filter appears to have opened a file descriptor outside of any function.  With embedded Perl, you should move any code that opens a file descriptor into filter_initialize.  On some systems, the C library may open a descriptor, but you should verify your filter just in case.");
    }
    return 0;
}

void
run_embedded_filter(void)
{
    char *args[] = { NULL };

    perl_call_argv("do_main_loop", G_DISCARD | G_NOARGS, args);
}
#endif

