modules/perlcore/libkviperlcore.cpp

//=============================================================================
//
//   File : libkviperlcore.cpp
//   Creation date : Tue Jul 13 13:03:31 2004 GMT by Szymon Stefanek
//
//   This file is part of the KVIrc IRC client distribution
//   Copyright (C) 2004-2010 Szymon Stefanek (pragma at kvirc dot net)
//
//   This program is FREE software. You can redistribute it and/or
//   modify it under the terms of the GNU General Public License
//   as published by the Free Software Foundation; either version 2
//   of the License, 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 GNU General Public License for more details.
//
//   You should have received a copy of the GNU General Public License
//   along with this program. If not, write to the Free Software Foundation,
//   Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
//
//=============================================================================

#include "KviModule.h"
#include "kvi_settings.h"
#include "KviLocale.h"
#include "kvi_out.h"
#include "KviWindow.h"
#include "KviApplication.h"
#include "KviKvsScript.h"
#include "KviKvsVariant.h"
#include "KviUserInput.h"
#include "KviPointerHashTable.h"

#include <QByteArray>

#ifdef DEBUG
#undef DEBUG
#endif

// I MUST say that the perl embedding process is somewhat ugly :(
// First of all the man pages are somewhat unreadable even
// for a non-novice perl user. The writer of each page assumed
// that you have already read each other page...
// Also browsing the pages with "man" is obviously out of mind
// but this can be solved by looking up some html docs on the net.
// Embedding multiple interpreters isn't that hard (after you
// have read perlembed) but to start passing parameters
// around you have to read at least perlembed, perlguts, perlxs,..
// take a look at the perlinternals and have a good trip
// around the web to find some examples for the functions
// that aren't explained enough in the pages.
// It gets even more weird when you attempt to include
// some XS functions... (what the heck is boot_DynaLoader ?).

// ... and I'm still convinced that I'm leaking memory with
// the perl values, but well ...

// anyway, once you struggled for a couple of days with all that
// stuff then you start getting things done... and it rox :)

// Note for kvirc4: perl embedding has changed between perl 5.8 and perl 5.10.
// This version should work nice with both, but warranty is 5.10-only.

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

#define NEED_eval_pv
#include "ppport.h"

#include "KviKvsRunTimeContext.h"

static KviKvsRunTimeContext * g_pCurrentKvsContext = nullptr;
static bool g_bExecuteQuiet = false;
static KviCString g_szLastReturnValue("");
static QStringList g_lWarningList;

// this is why we can't have nice things -- part of perl 5.17.1+
#ifdef __cplusplus
#define dNOOP (void)0
#else
#define dNOOP extern int Perl___notused(void)
#endif

#include "xs.inc"
#endif // COMPILE_PERL_SUPPORT

// perl redefines bool :///
#ifdef bool
#undef bool
#endif

#ifdef COMPILE_PERL_SUPPORT

#include "perlcoreinterface.h"

// This should be able to be rewritten in the form:
// static PerlInterpreter *m_pInterpreter

// people ... are you mad ? ... what the heck is "my_perl" ?
#define my_perl m_pInterpreter

class KviPerlInterpreter
{
public:
	KviPerlInterpreter(const QString & szContextName);
	~KviPerlInterpreter();

protected:
	QString m_szContextName;
	PerlInterpreter * m_pInterpreter;

public:
	bool init(); // if this fails then well.. :D
	void done();
	bool execute(const QString & szCode, QStringList & args, QString & szRetVal, QString & szError, QStringList & lWarnings);
	const QString & contextName() const { return m_szContextName; };
protected:
	QString svToQString(SV * sv);
};

KviPerlInterpreter::KviPerlInterpreter(const QString & szContextName)
{
	m_szContextName = szContextName;
	m_pInterpreter = nullptr;
}

KviPerlInterpreter::~KviPerlInterpreter()
{
	done();
}

// this kinda sux :(
// It SHOULD be mentioned somewhere that
// this function is in DynaLoader.a in the perl
// distribution and you MUST link it statically.

// Update: it is no more needed as of perl 5.10, since it is
// included in the standard libperl interface.

extern "C" void boot_DynaLoader(pTHX_ CV * cv);

extern "C" void xs_init(pTHX)
{
	char * file = (char *)__FILE__;
	// boot up the DynaLoader
	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
	// now bootstrap the KVIrc module
	// This stuff is simply cutted and pasted from xs.inc
	// since I don't really know if it's safe to call
	// something like
	//   CV * dummy;
	//   boot_KVIrc(aTHX,dummy);
	// ...
	newXS("KVIrc::echo", XS_KVIrc_echo, file);
	newXS("KVIrc::say", XS_KVIrc_say, file);
	newXS("KVIrc::warning", XS_KVIrc_warning, file);
	newXS("KVIrc::getLocal", XS_KVIrc_getLocal, file);
	newXS("KVIrc::setLocal", XS_KVIrc_setLocal, file);
	newXS("KVIrc::getGlobal", XS_KVIrc_getGlobal, file);
	newXS("KVIrc::setGlobal", XS_KVIrc_setGlobal, file);
	newXS("KVIrc::eval", XS_KVIrc_eval, file);
	newXS("KVIrc::internalWarning", XS_KVIrc_internalWarning, file);
}

bool KviPerlInterpreter::init()
{
	if(m_pInterpreter)
		done();
	const char * daArgs[] = { "yo", "-e", "0", "-w" };
	m_pInterpreter = perl_alloc();
	if(!m_pInterpreter)
		return false;
	PERL_SET_CONTEXT(m_pInterpreter);
	PL_perl_destruct_level = 1;
	perl_construct(m_pInterpreter);
	perl_parse(m_pInterpreter, xs_init, 4, (char **)daArgs, nullptr);
	QString szInitCode;

	// this part of the code seems to be unnecessary
	// even if it is created by the perl make process...
	//	"our %EXPORT_TAGS = ('all' => [qw(echo)]);\n"
	//	"our @EXPORT_OK = (qw(echo));\n"
	//	"our @EXPORT = qw();\n"
	// This is probably needed only if perl has to load
	// the XS through XSLoader ?
	// Maybe also the remaining part of the package
	// declaration could be dropped as well...
	// I just haven't tried :D

	szInitCode = QString(
	                 "{\n"
	                 "package KVIrc;\n"
	                 "require Exporter;\n"
	                 "our @ISA = qw(Exporter);\n"
	                 "1;\n"
	                 "}\n"
	                 "$g_szContext = \"%1\";\n"
	                 "$g_bExecuteQuiet = 0;\n"
	                 "$SIG{__WARN__} = sub\n"
	                 "{\n"
	                 "	my($p,$f,$l,$x);\n"
	                 "	($p,$f,$l) = caller;\n"
	                 "	KVIrc::internalWarning(\"At line \".$l.\" of Perl code: \");\n"
	                 "	KVIrc::internalWarning(join(' ',@_));\n"
	                 "}\n")
	                 .arg(m_szContextName);

	eval_pv(szInitCode.toUtf8().data(), false);
	return true;
}

void KviPerlInterpreter::done()
{
	if(!m_pInterpreter)
		return;
	PERL_SET_CONTEXT(m_pInterpreter);
	PL_perl_destruct_level = 1;
	perl_destruct(m_pInterpreter);
	perl_free(m_pInterpreter);
	m_pInterpreter = nullptr;
}

QString KviPerlInterpreter::svToQString(SV * sv)
{
	QString ret = "";
	if(!sv)
		return ret;
	STRLEN len;
	char * ptr = SvPV(sv, len);
	if(ptr)
		ret = ptr;
	return ret;
}

bool KviPerlInterpreter::execute(
    const QString & szCode,
    QStringList & args,
    QString & szRetVal,
    QString & szError,
    QStringList & lWarnings)
{
	if(!m_pInterpreter)
	{
		szError = __tr2qs_ctx("Internal error: Perl interpreter not initialized", "perl");
		return false;
	}

	g_lWarningList.clear();

	QByteArray szUtf8 = szCode.toUtf8();
	PERL_SET_CONTEXT(m_pInterpreter);

	// clear the _ array
	AV * pArgs = get_av("_", 1);
	SV * pArg = av_shift(pArgs);
	while(SvOK(pArg))
	{
		SvREFCNT_dec(pArg);
		pArg = av_shift(pArgs);
	}

	if(args.count() > 0)
	{
		// set the args in the _ arry
		av_unshift(pArgs, (I32)args.count());
		int idx = 0;
		for(auto tmp : args)
		{
			QByteArray szVal = tmp.toUtf8();
			pArg = newSVpv(szVal.data(), tmp.length());
			if(!av_store(pArgs, idx, pArg))
				SvREFCNT_dec(pArg);
			idx++;
		}
	}

	// call the code
	SV * pRet = eval_pv(szUtf8.data(), false);

	// clear the _ array again
	pArgs = get_av("_", 1);
	pArg = av_shift(pArgs);
	while(SvOK(pArg))
	{
		SvREFCNT_dec(pArg);
		pArg = av_shift(pArgs);
	}
	av_undef(pArgs);

	// get the ret value
	if(pRet)
	{
		if(SvOK(pRet))
			szRetVal = svToQString(pRet);
	}

	if(!g_lWarningList.isEmpty())
		lWarnings = g_lWarningList;

	// and the eventual error string
	pRet = get_sv("@", false);
	if(pRet)
	{
		if(SvOK(pRet))
		{
			szError = svToQString(pRet);
			if(!szError.isEmpty())
				return false;
		}
	}

	return true;
}

static KviPointerHashTable<QString, KviPerlInterpreter> * g_pInterpreters = nullptr;

static KviPerlInterpreter * perlcore_get_interpreter(const QString & szContextName)
{
	KviPerlInterpreter * i = g_pInterpreters->find(szContextName);
	if(i)
		return i;
	i = new KviPerlInterpreter(szContextName);
	if(!i->init())
	{
		delete i;
		return nullptr;
	}
	g_pInterpreters->replace(szContextName, i);
	return i;
}

static void perlcore_destroy_interpreter(const QString & szContextName)
{
	KviPerlInterpreter * i = g_pInterpreters->find(szContextName);
	if(!i)
		return;
	g_pInterpreters->remove(szContextName);
	i->done();
	delete i;
}

static void perlcore_destroy_all_interpreters()
{
	KviPointerHashTableIterator<QString, KviPerlInterpreter> it(*g_pInterpreters);

	while(it.current())
	{
		KviPerlInterpreter * i = it.current();
		i->done();
		delete i;
		++it;
	}
	g_pInterpreters->clear();
}

#endif // COMPILE_PERL_SUPPORT

static bool perlcore_module_ctrl(KviModule *, const char * cmd, void * param)
{
#ifdef COMPILE_PERL_SUPPORT
	if(kvi_strEqualCS(cmd, KVI_PERLCORECTRLCOMMAND_EXECUTE))
	{
		KviPerlCoreCtrlCommand_execute * ex = (KviPerlCoreCtrlCommand_execute *)param;
		if(ex->uSize != sizeof(KviPerlCoreCtrlCommand_execute))
			return false;
		g_pCurrentKvsContext = ex->pKvsContext;
		g_bExecuteQuiet = ex->bQuiet;
		if(ex->szContext.isEmpty())
		{
			KviPerlInterpreter * m = new KviPerlInterpreter("temporary");
			if(!m->init())
			{
				delete m;
				return false;
			}
			ex->bExitOk = m->execute(ex->szCode, ex->lArgs, ex->szRetVal, ex->szError, ex->lWarnings);
			m->done();
			delete m;
		}
		else
		{
			KviPerlInterpreter * m = perlcore_get_interpreter(ex->szContext);
			ex->bExitOk = m->execute(ex->szCode, ex->lArgs, ex->szRetVal, ex->szError, ex->lWarnings);
		}
		return true;
	}
	if(kvi_strEqualCS(cmd, KVI_PERLCORECTRLCOMMAND_DESTROY))
	{
		KviPerlCoreCtrlCommand_destroy * de = (KviPerlCoreCtrlCommand_destroy *)param;
		if(de->uSize != sizeof(KviPerlCoreCtrlCommand_destroy))
			return false;
		perlcore_destroy_interpreter(de->szContext);
		return true;
	}
#endif // COMPILE_PERL_SUPPORT
	return false;
}

static bool perlcore_module_init(KviModule *)
{
#ifdef COMPILE_PERL_SUPPORT
	g_pInterpreters = new KviPointerHashTable<QString, KviPerlInterpreter>(17, false);
	g_pInterpreters->setAutoDelete(false);
	int daArgc = 4;
	const char * daArgs[] = { "yo", "-e", "0", "-w" };
	char ** daEnv = nullptr;
	PERL_SYS_INIT3(&daArgc, (char ***)&daArgs, &daEnv);
	return true;
#else  // !COMPILE_PERL_SUPPORT
	return false;
#endif // !COMPILE_PERL_SUPPORT
}

static bool perlcore_module_cleanup(KviModule *)
{
#ifdef COMPILE_PERL_SUPPORT
	perlcore_destroy_all_interpreters();
	delete g_pInterpreters;
	g_pInterpreters = nullptr;
// ifdef workaround for #842
#ifndef COMPILE_ON_MAC
	PERL_SYS_TERM();
#endif
#endif // COMPILE_PERL_SUPPORT
	return true;
}

static bool perlcore_module_can_unload(KviModule *)
{
#ifdef COMPILE_PERL_SUPPORT
	return false;
	/* return (g_pInterpreters->count() == 0);
	 * Perlcore module can't be cleanly unloaded since PERL_SYS_INIT3
	 * and PERL_SYS_TERM should never be called more than once (#1105)
	 */
#endif // COMPILE_PERL_SUPPORT
	return true;
}

KVIRC_MODULE(
    "PerlCore",                                                     // module name
    "4.0.0",                                                        // module version
    "Copyright (C) 2008 Szymon Stefanek (pragma at kvirc dot net)", // author & (C)
    "Perl scripting engine core",
    perlcore_module_init,
    perlcore_module_can_unload,
    perlcore_module_ctrl,
    perlcore_module_cleanup,
    "perl")