/*
 * Copyright (C) 2002 Stichting NLnet, Netherlands, stichting@nlnet.nl.
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the
 * above copyright notice and this permission notice appear in all
 * copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND STICHTING NLNET
 * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
 * STICHTING NLNET BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
 * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
 * OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
 * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE
 * USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 * The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
 * conceived and contributed by Rob Butler.
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the
 * above copyright notice and this permission notice appear in all
 * copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND ROB BUTLER
 * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
 * ROB BUTLER BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
 * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
 * OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
 * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE
 * USE OR PERFORMANCE OF THIS SOFTWARE.
 */

/*
 * Copyright (C) 1999-2001, 2016  Internet Systems Consortium, Inc. ("ISC")
 *
 * This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at http://mozilla.org/MPL/2.0/.
 */

/*
 * Copyright (C) 2009-2012  John Eaglesham
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND JOHN EAGLESHAM
 * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
 * JOHN EAGLESHAM BE LIABLE FOR ANY SPECIAL, DIRECT,
 * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
 * FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
 * NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
 * WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 */

#include <config.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>

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

#include <dlz_minimal.h>

#include "dlz_perl_driver.h"

/* Enable debug logging? */
#if 0
#define carp(...) 	cd->log(ISC_LOG_INFO, __VA_ARGS__);
#else
#define carp(...)
#endif

#ifndef MULTIPLICITY
/* This is a pretty terrible work-around for handling HUP/rndc reconfig, but
 * the way BIND/DLZ handles reloads causes it to create a second back end
 * before removing the first. In the case of a single global interpreter,
 * serious problems arise. We can hack around this, but it's much better to do
 * it properly and link against a perl compiled with multiplicity. */
static PerlInterpreter *global_perl = NULL;
static int global_perl_dont_free = 0;
#endif

typedef struct config_data {
	PerlInterpreter	*perl;
	char			*perl_source;
	SV				*perl_class;

	/* Functions given to us by bind9 */
	log_t *log;
	dns_sdlz_putrr_t *putrr;
	dns_sdlz_putnamedrr_t *putnamedrr;
	dns_dlz_writeablezone_t *writeable_zone;
} config_data_t;

/* Note, this code generates warnings due to lost type qualifiers.  This code
 * is (almost) verbatim from perlembed, and is known to work correctly despite
 * the warnings.
 */
EXTERN_C void xs_init (pTHX);
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
EXTERN_C void boot_DLZ_Perl__clientinfo (pTHX_ CV* cv);
EXTERN_C void boot_DLZ_Perl (pTHX_ CV* cv);
EXTERN_C void
xs_init(pTHX)
{
		char *file = __FILE__;
		dXSUB_SYS;

		/* DynaLoader is a special case */
		newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
		newXS("DLZ_Perl::clientinfo::bootstrap", boot_DLZ_Perl__clientinfo, file);
		newXS("DLZ_Perl::bootstrap", boot_DLZ_Perl, file);
}

/*
 * methods
 */

/*
 * remember a helper function, from the bind9 dlz_dlopen driver
 */
static void b9_add_helper(config_data_t *state,
			  const char *helper_name, void *ptr)
{
	if (strcmp(helper_name, "log") == 0)
		state->log = ptr;
	if (strcmp(helper_name, "putrr") == 0)
		state->putrr = ptr;
	if (strcmp(helper_name, "putnamedrr") == 0)
		state->putnamedrr = ptr;
	if (strcmp(helper_name, "writeable_zone") == 0)
		state->writeable_zone = ptr;
}

int dlz_version(unsigned int *flags) {
	return DLZ_DLOPEN_VERSION;
}

isc_result_t dlz_allnodes(const char *zone, void *dbdata,
			  dns_sdlzallnodes_t *allnodes)
{
	config_data_t *cd = (config_data_t *) dbdata;
	isc_result_t retval;
	int rrcount, r;
	SV *record_ref;
	SV **rr_name;
	SV **rr_type;
	SV **rr_ttl;
	SV **rr_data;
#ifdef MULTIPLICITY
	PerlInterpreter *my_perl = cd->perl;
#endif
	dSP;

	PERL_SET_CONTEXT(cd->perl);
	ENTER;
	SAVETMPS;
	
	PUSHMARK(SP);
	XPUSHs(cd->perl_class);
	XPUSHs(sv_2mortal(newSVpv(zone, 0)));
	PUTBACK;

	carp("DLZ Perl: Calling allnodes for zone %s", zone);
	rrcount = call_method("allnodes", G_ARRAY|G_EVAL);
	carp("DLZ Perl: Call to allnodes returned rrcount of %i", rrcount);

	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		POPs;
		cd->log(ISC_LOG_ERROR, "DLZ Perl: allnodes for zone %s died in eval: %s", zone, SvPV_nolen(ERRSV));
		retval = ISC_R_FAILURE;
		goto CLEAN_UP_AND_RETURN;
	}

	if (!rrcount) {
		retval = ISC_R_NOTFOUND;
		goto CLEAN_UP_AND_RETURN;
	}

	retval = ISC_R_SUCCESS;
	r = 0;
	while (r++ < rrcount) {
		record_ref = POPs;
		if (
			(!SvROK(record_ref)) ||
			(SvTYPE(SvRV(record_ref)) != SVt_PVAV)
		) {
			cd->log(ISC_LOG_ERROR,
				"DLZ Perl: allnodes for zone %s "
				"returned an invalid value "
				"(expected array of arrayrefs)",
				zone);
			retval = ISC_R_FAILURE;
			break;
		}

		record_ref = SvRV(record_ref);

		rr_name = av_fetch((AV *) record_ref, 0, 0);
		rr_type = av_fetch((AV *) record_ref, 1, 0);
		rr_ttl = av_fetch((AV *) record_ref, 2, 0);
		rr_data = av_fetch((AV *) record_ref, 3, 0);

		if (rr_name == NULL || rr_type == NULL ||
		    rr_ttl == NULL || rr_data == NULL)
		{
			cd->log(ISC_LOG_ERROR,
				"DLZ Perl: allnodes for zone %s "
				"returned an array that was missing data",
				zone);
			retval = ISC_R_FAILURE;
			break;
		}

		carp("DLZ Perl: Got record %s/%s = %s",
		     SvPV_nolen(*rr_name), SvPV_nolen(*rr_type),
		     SvPV_nolen(*rr_data));
   		retval = cd->putnamedrr(allnodes,
					SvPV_nolen(*rr_name),
					SvPV_nolen(*rr_type),
					SvIV(*rr_ttl), SvPV_nolen(*rr_data));
		if (retval != ISC_R_SUCCESS) {
			cd->log(ISC_LOG_ERROR,
				"DLZ Perl: putnamedrr in allnodes "
				"for zone %s failed with code %i "
				"(did lookup return invalid record data?)",
				zone, retval);
			break;
		}
	}

CLEAN_UP_AND_RETURN:
	PUTBACK;
	FREETMPS;
	LEAVE;

	carp("DLZ Perl: Returning from allnodes, r = %i, retval = %i",
	     r, retval);

	return (retval);
}

isc_result_t
dlz_allowzonexfr(void *dbdata, const char *name, const char *client) {
	config_data_t *cd = (config_data_t *) dbdata;
	int r;
	isc_result_t retval;
#ifdef MULTIPLICITY
	PerlInterpreter *my_perl = cd->perl;
#endif
	dSP;

	PERL_SET_CONTEXT(cd->perl);
	ENTER;
	SAVETMPS;
	
	PUSHMARK(SP);
	XPUSHs(cd->perl_class);
	XPUSHs(sv_2mortal(newSVpv(name, 0)));
	XPUSHs(sv_2mortal(newSVpv(client, 0)));
	PUTBACK;

	r = call_method("allowzonexfr", G_SCALAR|G_EVAL);
	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		/*
		 * On error there's an undef at the top of the stack. Pop
		 * it away so we don't leave junk on the stack for the next
		 * caller.
		 */
		POPs;
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl: allowzonexfr died in eval: %s",
			SvPV_nolen(ERRSV));
		retval = ISC_R_FAILURE;
	} else if (r == 0) {
		/* Client returned nothing -- zone not found. */
	 	retval = ISC_R_NOTFOUND;
	} else if (r > 1) {
		/* Once again, clean out the stack when possible. */
		while (r--) POPi;
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl: allowzonexfr returned too many parameters!");
		retval = ISC_R_FAILURE;
	} else {
		/*
		 * Client returned true/false -- we're authoritative for
		 * the zone.
		 */
		r = POPi;
		if (r)
			retval = ISC_R_SUCCESS;
		else
			retval = ISC_R_NOPERM;
	}

	PUTBACK;
	FREETMPS;
	LEAVE;
	return (retval);
}

#if DLZ_DLOPEN_VERSION < 3
isc_result_t
dlz_findzonedb(void *dbdata, const char *name)
#else
isc_result_t
dlz_findzonedb(void *dbdata, const char *name,
	       dns_clientinfomethods_t *methods,
	       dns_clientinfo_t *clientinfo)
#endif
{
	config_data_t *cd = (config_data_t *) dbdata;
	int r;
	isc_result_t retval;
#ifdef MULTIPLICITY
	PerlInterpreter *my_perl = cd->perl;
#endif

#if DLZ_DLOPEN_VERSION >= 3
	UNUSED(methods);
	UNUSED(clientinfo);
#endif

	dSP;
	carp("DLZ Perl: findzone looking for '%s'", name);

	PERL_SET_CONTEXT(cd->perl);
	ENTER;
	SAVETMPS;
	
	PUSHMARK(SP);
	XPUSHs(cd->perl_class);
	XPUSHs(sv_2mortal(newSVpv(name, 0)));
	PUTBACK;

	r = call_method("findzone", G_SCALAR|G_EVAL);
	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		/*
		 * On error there's an undef at the top of the stack. Pop
		 * it away so we don't leave junk on the stack for the next
		 * caller.
		 */
		POPs;
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl: findzone died in eval: %s",
			SvPV_nolen(ERRSV));
		retval = ISC_R_FAILURE;
	} else if (r == 0) {
	 	retval = ISC_R_FAILURE;
	} else if (r > 1) {
		/* Once again, clean out the stack when possible. */
		while (r--) POPi;
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl: findzone returned too many parameters!");
		retval = ISC_R_FAILURE;
	} else {
		r = POPi;
		if (r)
			retval = ISC_R_SUCCESS;
		else
			retval = ISC_R_NOTFOUND;
	}

	PUTBACK;
	FREETMPS;
	LEAVE;
	return (retval);
}


#if DLZ_DLOPEN_VERSION == 1
isc_result_t
dlz_lookup(const char *zone, const char *name,
	   void *dbdata, dns_sdlzlookup_t *lookup)
#else
isc_result_t
dlz_lookup(const char *zone, const char *name,
	   void *dbdata, dns_sdlzlookup_t *lookup,
	   dns_clientinfomethods_t *methods,
	   dns_clientinfo_t *clientinfo)
#endif
{
	isc_result_t retval;
	config_data_t *cd = (config_data_t *) dbdata;
	int rrcount, r;
	dlz_perl_clientinfo_opaque opaque;
	SV *record_ref;
	SV **rr_type;
	SV **rr_ttl;
	SV **rr_data;
#ifdef MULTIPLICITY
	PerlInterpreter *my_perl = cd->perl;
#endif

#if DLZ_DLOPEN_VERSION >= 2
	UNUSED(methods);
	UNUSED(clientinfo);
#endif

	dSP;
	PERL_SET_CONTEXT(cd->perl);
	ENTER;
	SAVETMPS;

	opaque.methods = methods;
	opaque.clientinfo = clientinfo;

	PUSHMARK(SP);
	XPUSHs(cd->perl_class);
	XPUSHs(sv_2mortal(newSVpv(name, 0)));
	XPUSHs(sv_2mortal(newSVpv(zone, 0)));
	XPUSHs(sv_2mortal(newSViv((IV)&opaque)));
	PUTBACK;

	carp("DLZ Perl: Searching for name %s in zone %s", name, zone);
	rrcount = call_method("lookup", G_ARRAY|G_EVAL);
	carp("DLZ Perl: Call to lookup returned %i", rrcount);

	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		POPs;
		cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup died in eval: %s",
			SvPV_nolen(ERRSV));
		retval = ISC_R_FAILURE;
		goto CLEAN_UP_AND_RETURN;
	}

	if (!rrcount) {
		retval = ISC_R_NOTFOUND;
		goto CLEAN_UP_AND_RETURN;
	}

	retval = ISC_R_SUCCESS;
	r = 0;
	while (r++ < rrcount) {
		record_ref = POPs;
		if ((!SvROK(record_ref)) ||
		    (SvTYPE(SvRV(record_ref)) != SVt_PVAV))
		{
			cd->log(ISC_LOG_ERROR,
				"DLZ Perl: lookup returned an "
				"invalid value (expected array of arrayrefs)!");
			retval = ISC_R_FAILURE;
			break;
		}

		record_ref = SvRV(record_ref);

		rr_type = av_fetch((AV *) record_ref, 0, 0);
		rr_ttl = av_fetch((AV *) record_ref, 1, 0);
		rr_data = av_fetch((AV *) record_ref, 2, 0);

		if (rr_type == NULL || rr_ttl == NULL || rr_data == NULL) {
			cd->log(ISC_LOG_ERROR,
				"DLZ Perl: lookup for record %s in "
				"zone %s returned an array that was "
				"missing data", name, zone);
			retval = ISC_R_FAILURE;
			break;
		}

		carp("DLZ Perl: Got record %s = %s",
		     SvPV_nolen(*rr_type), SvPV_nolen(*rr_data));
		retval = cd->putrr(lookup, SvPV_nolen(*rr_type),
				   SvIV(*rr_ttl), SvPV_nolen(*rr_data));

		if (retval != ISC_R_SUCCESS) {
			cd->log(ISC_LOG_ERROR,
				"DLZ Perl: putrr for lookup of %s in "
				"zone %s failed with code %i "
				"(did lookup return invalid record data?)",
				name, zone, retval);
			break;
		}
	}

CLEAN_UP_AND_RETURN:
	PUTBACK;
	FREETMPS;
	LEAVE;

	carp("DLZ Perl: Returning from lookup, r = %i, retval = %i", r, retval);

	return (retval);
}

const char *
#ifdef MULTIPLICITY
missing_perl_method(const char *perl_class_name, PerlInterpreter *my_perl)
#else
missing_perl_method(const char *perl_class_name)
#endif
{
	const int BUF_LEN = 64; /* Should be big enough, right? hah */
	char full_name[BUF_LEN];
	const char *methods[] = { "new", "findzone", "lookup", NULL };
	int i = 0;

	while( methods[i] != NULL ) {
		snprintf(full_name, BUF_LEN, "%s::%s",
			 perl_class_name, methods[i]);

		if (get_cv(full_name, 0) == NULL) {
			return methods[i];
		}
		i++;
	}

	return (NULL);
}

isc_result_t
dlz_create(const char *dlzname, unsigned int argc, char *argv[],
	   void **dbdata, ...)
{
	config_data_t *cd;
	char *init_args[] = { NULL, NULL };
	char *perlrun[] = { "", NULL, "dlz perl", NULL };
	char *perl_class_name;
	int r;
	va_list ap;
	const char *helper_name;
	const char *missing_method_name;
	char *call_argv_args = NULL;
#ifdef MULTIPLICITY
	PerlInterpreter *my_perl;
#endif

	cd = malloc(sizeof(config_data_t));
	if (cd == NULL)
		return (ISC_R_NOMEMORY);

	memset(cd, 0, sizeof(config_data_t));

	/* fill in the helper functions */
	va_start(ap, dbdata);
	while ((helper_name = va_arg(ap, const char *)) != NULL) {
		b9_add_helper(cd, helper_name, va_arg(ap, void*));
	}
	va_end(ap);

	if (argc < 2) {
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl '%s': Missing script argument.",
			dlzname);
		free(cd);
		return (ISC_R_FAILURE);
	}

	if (argc < 3) {
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl '%s': Missing class name argument.",
			dlzname);
		free(cd);
		return (ISC_R_FAILURE);
	}
	perl_class_name = argv[2];

	cd->log(ISC_LOG_INFO, "DLZ Perl '%s': Loading '%s' from location '%s'",
		 dlzname, perl_class_name, argv[1], argc);

#ifndef MULTIPLICITY
	if (global_perl) {
		/*
		 * PERL_SET_CONTEXT not needed here as we're guaranteed to
		 * have an implicit context thanks to an undefined
		 * MULTIPLICITY.
		 */
		PL_perl_destruct_level = 1;
		perl_destruct(global_perl);
		perl_free(global_perl);
		global_perl = NULL;
		global_perl_dont_free = 1;
	}
#endif

	cd->perl = perl_alloc();
	if (cd->perl == NULL) {
		free(cd);
		return (ISC_R_FAILURE);
	}
#ifdef MULTIPLICITY
	my_perl = cd->perl;
#endif
	PERL_SET_CONTEXT(cd->perl);
 
	/*
	 * We will re-create the interpreter during an rndc reconfig, so we
	 * must set this variable per perlembed in order to insure we can
	 * clean up Perl at a later time.
	 */
	PL_perl_destruct_level = 1;
	perl_construct(cd->perl);
	PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
	/* Prevent crashes from clients writing to $0 */
	PL_origalen = 1;

	cd->perl_source = strdup(argv[1]);
	if (cd->perl_source == NULL) {
		free(cd);
		return (ISC_R_NOMEMORY);
	}

	perlrun[1] = cd->perl_source;
	if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) {
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl '%s': Failed to parse Perl script, aborting",
			dlzname);
		goto CLEAN_UP_PERL_AND_FAIL;
	}

	/* Let Perl know about our callbacks. */
	call_argv("DLZ_Perl::clientinfo::bootstrap",
		  G_DISCARD|G_NOARGS, &call_argv_args);
	call_argv("DLZ_Perl::bootstrap",
		  G_DISCARD|G_NOARGS, &call_argv_args);

	/*
	 * Run the script. We don't really need to do this since we have
	 * the init callback, but there's not really a downside either.
	 */
	if (perl_run(cd->perl)) {
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl '%s': Script exited with an error, aborting",
			dlzname);
		goto CLEAN_UP_PERL_AND_FAIL;
	}

#ifdef MULTIPLICITY
	if (missing_method_name = missing_perl_method(perl_class_name, my_perl))
#else
	if (missing_method_name = missing_perl_method(perl_class_name))
#endif
	{
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl '%s': Missing required function '%s', "
			"aborting", dlzname, missing_method_name);
		goto CLEAN_UP_PERL_AND_FAIL;
	}

	dSP;
	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0)));

	/* Build flattened hash of config info. */
	XPUSHs(sv_2mortal(newSVpv("log_context", 0)));
	XPUSHs(sv_2mortal(newSViv((IV)cd->log)));

	/* Argument to pass to new? */
	if (argc == 4) {
		XPUSHs(sv_2mortal(newSVpv("argv", 0)));
		XPUSHs(sv_2mortal(newSVpv(argv[3], 0)));
	}

	PUTBACK;

	r = call_method("new", G_EVAL|G_SCALAR);

	SPAGAIN;

	if (r) cd->perl_class = SvREFCNT_inc(POPs);

	PUTBACK;
	FREETMPS;
	LEAVE;

	if (SvTRUE(ERRSV)) {
		POPs;
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl '%s': new died in eval: %s",
			dlzname, SvPV_nolen(ERRSV));
		goto CLEAN_UP_PERL_AND_FAIL;
	}

	if (!r || !sv_isobject(cd->perl_class)) {
		cd->log(ISC_LOG_ERROR,
			"DLZ Perl '%s': new failed to return a blessed object",
			dlzname);
		goto CLEAN_UP_PERL_AND_FAIL;
	}

	*dbdata = cd;

#ifndef MULTIPLICITY
	global_perl = cd->perl;
#endif
	return (ISC_R_SUCCESS);

CLEAN_UP_PERL_AND_FAIL:
	PL_perl_destruct_level = 1;
	perl_destruct(cd->perl);
	perl_free(cd->perl);
	free(cd->perl_source);
	free(cd);
	return (ISC_R_FAILURE);
}

void dlz_destroy(void *dbdata) {
	config_data_t *cd = (config_data_t *) dbdata;
#ifdef MULTIPLICITY
	PerlInterpreter *my_perl = cd->perl;
#endif

	cd->log(ISC_LOG_INFO, "DLZ Perl: Unloading driver.");

#ifndef MULTIPLICITY
	if (!global_perl_dont_free) {
#endif
		PERL_SET_CONTEXT(cd->perl);
		PL_perl_destruct_level = 1;
		perl_destruct(cd->perl);
		perl_free(cd->perl);
#ifndef MULTIPLICITY
		global_perl_dont_free = 0;
		global_perl = NULL;
	}
#endif

	free(cd->perl_source);
	free(cd);
}
