Click here to Skip to main content
Click here to Skip to main content
 
Add your own
alternative version

CPerlWrap - A class wrapper for embedding Perl into your MFC program

, 23 Feb 2012 CPOL
Simple class to allow fast, easy access to Perl and Perl variables.
// PerlWrapSTL.cpp : implementation file
//

#include "stdafx.h"
#include "PerlWrapSTL.h"


#if _MSC_VER < 1400
#error "PerlWrap using STL version not working with VC6 -- Use MFC version"
#endif


// I don't know if the following is really necessary, but it is safe enough
// This is from PXPerl on www.codeproject.com and seems like a good idea
#ifdef DEBUG
#define POP_DEBUG
#pragma push_macro("DEBUG")
#undef DEBUG
#endif

// These are typically found in c:/Perl/lib/CORE, see PerlWrap.h for details.
// Basically, change your project settings to search the proper directory.
#pragma warning ( disable : 4100 )

#include "config.h"
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#ifdef POP_DEBUG
#pragma pop_macro("DEBUG")
#endif

// These are defined in some of the Perl headers and they tend to
// interfere with member functions with the same names
#ifdef bool
#undef bool
#endif

#undef Null
#undef Copy
#undef Pause
#undef Move
#undef open
#undef write
#undef read
#undef eof
#undef close
#undef IsWinNT
#undef ftell
#undef fseek
#undef free
#undef malloc


#ifdef _DEBUG
#define new DEBUG_NEW
#undef THIS_FILE
static char THIS_FILE[] = __FILE__;
#endif

/////////////////////////////////////////////////////////////////////////////
// CPerlWrapSTL

/////////////////////////////////////////////////////////////////////////////
// This stuff is used to be able to have dynamically loaded modules. If the
// module is not dynamically loadable, then it needs an entry in this xs_init()
// function. Since this function is passed along to a C program, it cannot be
// a member of the class. Which means you would need either to have all modules
// you are going to use mentioned in this one function, or you get to do something
// unthinkable with the stack to eliminate the implicit 'this' first argument
// of a member function.
//
// I don't want to think about that.   :-(
//
// For each module, you need something like this:
//
// EXTERN_C void boot_Socket (pTHX_ CV* cv);
//
// DynaLoader is different and I always include it. At least pure Perl modules
// can be 'use'ed without warnings. See perlembed for more details. Good luck!
////////////////////////////////////////////////////////////////////////////////
// From:  perl -MExtUtils::Embed -e ccopts -e ldopts
// with modifications. See manpage for perlembed
#define _CONSOLE 
#define NO_STRICT 
#define PERL_TEXTMODE_SCRIPTS 
#define USE_SITECUSTOMIZE 
#define PERL_IMPLICIT_CONTEXT 
#define PERL_IMPLICIT_SYS 
#define USE_PERLIO 
#define _USE_32BIT_TIME_T  




#pragma warning(push)
#pragma warning(disable : 4100)	// my_perl: unreferenced formal parameter

#if 1	/* Perl 14.2 or later */

// Generated from: perl -MExtUtils::Embed -e xsinit -- -o perlxsi.c
extern "C"
{
static void xs_init (pTHX);
void boot_DynaLoader (pTHX_ CV* cv);
void boot_Win32CORE (pTHX_ CV* cv);

//lint -esym(715,my_perl)	not referenced
//lint -esym(818,my_perl)	could be declared as pointing to const

static void
xs_init(pTHX)
{
	char *file = __FILE__;
	dXSUB_SYS;

	/* DynaLoader is a special case */
	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
	newXS("Win32CORE::bootstrap", boot_Win32CORE, file);
}
}
#else	/* Perl 5.7 or earlier */

EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);

EXTERN_C void
xs_init(pTHXo)
{
	char *file = __FILE__;
	dXSUB_SYS;
	
	/* DynaLoader is a special case */
	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
	
	// add other modules here. Please don't ask me about this; I don't know
	// perlguts. That's why this class exists!
	// newXS("Socket::bootstrap", boot_Socket, file);
}
#endif

#pragma warning(pop)



CPerlWrapSTL::CPerlWrapSTL()
{
	// Much of this is straight out of perlembed. We are setting up an independent
	// Perl instance in its own thread. The 'BEGIN' line is to allow warning messages
	// that are normally sent to STDERR (and therefore lost in this environment) to be
	// stored in the $__w_warnings variable. This gives the user half a chance to debug
	// a script. The getWarnings() and clearWarnings() methods are used to get to this
	// variable
	char *embedding[] = {"", "-e", "BEGIN{ $SIG{__WARN__} = sub { $__w_warnings .= $_[0] } }" };
	int argc = sizeof(embedding)/sizeof(embedding[0]);	// 3?
	char **argv = embedding;
	PERL_SYS_INIT(&argc,&argv);	// new in Perl 5.14.2 (and probably for many versions before!)
	
	// Use a local variable of the correct type to avoid constantly casting my_perl
	PerlInterpreter *tperl = perl_alloc();
	my_perl = tperl;
	
	PERL_SET_CONTEXT(tperl);		// always do this in order to get correct thread
	PL_perl_destruct_level = 1;     // ensure proper and complete cleanup when closing Perl
	perl_construct(tperl);
	
	
	//perl_parse(my_perl, NULL, 3, embedding, (char **)NULL);	// use default environment
	perl_parse(tperl, xs_init, 3, embedding, (char **)NULL);	// use modules listed in xs_init()
	
	PL_exit_flags |= PERL_EXIT_DESTRUCT_END;     // run the END block when finished (post-5.7)
	
	perl_run(tperl);
	
	eval_error = "";                    // saved $@ value
	last_eval = (SV *)&PL_sv_undef;     // saved result of last eval() (from doScript())
	
	failOnWarning = false;				// Warnings alone will not cause doScript to return FALSE
	clearWarningsOnScript = true;		// clear out warnings automatically for each doScript call
}

CPerlWrapSTL::~CPerlWrapSTL()
{
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	perl_destruct((PerlInterpreter *)my_perl);
	perl_free((PerlInterpreter *)my_perl);
	my_perl = NULL;
	last_eval = NULL;
}

bool CPerlWrapSTL::doScript(std::string script)
{
	if(clearWarningsOnScript)
	{
		clearWarnings();     // useful if you don't want a collection of warning messages...
	}
	
	PERL_SET_CONTEXT(my_perl);          // ensure correct Perl thread
	last_eval = eval_pv(script.c_str(), FALSE);		// eval(p) and don't abort if 'p' throws an exception

	//lint -e{666}	Expression with side effects passed to repeated parameter 1 in macro 'SvPV_nolen'
	eval_error = SvPV_nolen(get_sv("@", FALSE));     // Get any error/exception message from eval()
	
	bool retval = eval_error.empty();     // non-empty if there was an error/exception thrown
	if(!retval && failOnWarning)
	{
		// If a Warning constitutes an error -- good debugging practice
		retval = getWarnings().empty();
	}
	return retval;
}

bool CPerlWrapSTL::setFloatVal(std::string varName, double value)
{
	
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	
	// Create the scalar if it doesn't exist, turn off spurious warnings
	SV *v = get_sv(varName.c_str(), TRUE|GV_ADDMULTI);
	if(!v) 
		return false;
	
	sv_setnv(v, value);
	return true;
}

bool CPerlWrapSTL::getFloatVal(std::string varName, double &val)
{
	
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	SV *v = get_sv(varName.c_str(), FALSE);     // FALSE means don't create if it doesn't already exist
	if(!v) 
		return false;
	
	val = SvNV(v);
	return true;
}

bool CPerlWrapSTL::setIntVal(std::string varName, int value)
{
	
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	
	// Create the scalar if it doesn't exist, turn off spurious warnings
	SV *v = get_sv(varName.c_str(), TRUE|GV_ADDMULTI);
	if(!v) 
		return false;
	
	sv_setiv(v, value);
	return true;
}

bool CPerlWrapSTL::getIntVal(std::string varName, int &val)
{
	
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	SV *v = get_sv(varName.c_str(), FALSE);     // FALSE means don't create if it doesn't already exist
	if(!v) 
		return false;
    
	val = SvIV(v);
	return true;
}

bool CPerlWrapSTL::setStringVal(std::string varName, std::string value)
{
	
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	
	// Create the scalar if it doesn't exist, turn off spurious warnings
	SV *v = get_sv(varName.c_str(), TRUE|GV_ADDMULTI);
	if(!v) 
		return false;
	sv_setpv(v, value.c_str());
	return true;
}

bool CPerlWrapSTL::getStringVal(std::string varName, std::string &val)
{
	
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	SV *v = get_sv(varName.c_str(), FALSE);     // FALSE means don't create if it doesn't already exist
	if(!v) 
		return false;
    
	val = SvPV_nolen(v);
	return true;
}

bool CPerlWrapSTL::setArrayVal(std::string varName, string_vector &value)
{
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	
	// Create the array if it doesn't exist, turn off spurious warnings
	AV *v = get_av(varName.c_str(), TRUE|GV_ADDMULTI);
	if(!v) 
		return false;
	
	av_clear(v);     // clear out all previous values (if any)
	
	string_vector::iterator iter;
	for(iter = value.begin(); iter !=   value.end(); iter++)
	{
		SV *val = newSVpv((*iter).c_str(),0);
		if(!val) 
			return false;
		av_push(v, val);
	}
	return true;
}

bool CPerlWrapSTL::getArrayVal(std::string varName, string_vector &values)
{
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	
	AV *v = get_av(varName.c_str(), FALSE);     // don't create if it doesn't exist
	
	if(!v) 
		return false;
	
	int len = av_len(v) + 1;          // number of elements in array
	values.clear();
	
	int loopVar;
	for(loopVar = 0; loopVar < len; loopVar++)
	{
		SV **val = av_fetch(v, loopVar, 0);     // 0 means to not change the value
		if(!val) 
			return false;
		
		values.push_back(SvPV_nolen(*val));
	}
	
	return true;
}

bool CPerlWrapSTL::setHashVal(std::string varName, string_map &value)
{
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	
	// Create the hash if it doesn't exist, turn off spurious warnings
	HV *v = get_hv(varName.c_str(), TRUE|GV_ADDMULTI);
	if(!v) 
		return false;
	hv_clear(v);     // clear out all previous values (if any)
	
	std::string hkey;
	std::string hval;
    
	string_map::iterator iter;
	for( iter = value.begin(); iter != value.end(); iter++ )
	{
		hkey = (*iter).first;
		hval = (*iter).second;
		SV *svval = newSVpv(hval.c_str(),0);     // make a string SV
		if(!svval) 
			return false;
		hv_store(v,hkey.c_str(),hkey.size(), svval, 0);	//lint !e713	Loss of precision (arg. no. 4)
	}
	return true;
}

bool CPerlWrapSTL::getHashVal(std::string varName, string_map &value)
{
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	
	// Get the hash if it exists
	HV *v = get_hv(varName.c_str(), FALSE);
	if(!v) 
		return false;
	
	// Now we have to get a list of keys
	hv_iterinit(v);     // get beginning iterator
	HE *hashEntry;     // pointer to current hashentry
	while((hashEntry = hv_iternext(v)) != NULL)
	{
		long keylen;
		// char keybuf[10240];     // bigger-hammer-is-better school of software engineering
		
		// Get the key
		std::string keyname(hv_iterkey(hashEntry, &keylen));
		if(keyname.empty()) 
			return false;
		
		//          strncpy(keybuf,keyname,keylen);
		//          keybuf[keylen] = 0;
		
		// Now get the value -- its OK to have an empty value in a hash
		std::string val;
		SV *mysv = hv_iterval(v, hashEntry);
		if(!mysv)
		{
			val = "";
		}
		else
		{
			val = SvPV_nolen(mysv);
		}
		
		value[keyname.c_str()] = val;
	}
	return true;
}

std::string CPerlWrapSTL::getErrorMsg(void) const
{
	// gets any error/exception from last eval (found in $@)
	return eval_error;
}

double CPerlWrapSTL::getFloatEval(void)
{
	// Get result of last eval in floating point format
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	return SvNV((SV *)last_eval);
}

int CPerlWrapSTL::getIntEval(void)
{
	// Get result of last eval in integer format
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	return SvIV((SV *)last_eval);
}

std::string CPerlWrapSTL::getStringEval(void)
{
	// Get result of last eval in string format
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	return SvPV_nolen((SV *)last_eval);
}

// Normally warning messages are sent to STDERR, but this isn't really
// useful in a Windows environment. Instead, they are saved in $main::__w_warnings
// for retrieval during debugging
std::string CPerlWrapSTL::getWarnings()
{
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	std::string retval;
	getStringVal("main::__w_warnings", retval);
	return retval;
}

// The warnings accumulate forever unless explicitly cleared out
void CPerlWrapSTL::clearWarnings()
{
	PERL_SET_CONTEXT(my_perl);     // ensure correct Perl thread
	setStringVal("main::__w_warnings","");
}

// If you set this to TRUE, then if there are warning messages from a
// doScript(), then doScript() will return FALSE. If you have done your
// Perl code correctly, you should never get warnings so this is good
// for detecting a problem.
bool CPerlWrapSTL::SetfailOnWarning(bool val)
{
	bool retval = failOnWarning;
	failOnWarning = val;
	return retval;
}

// If TRUE, then past warnings are cleared just before executing the
// script given to doScript().
bool CPerlWrapSTL::SetclearWarningsOnScript(bool val)
{
	bool retval = clearWarningsOnScript;
	clearWarningsOnScript = val;
	return retval;
}

By viewing downloads associated with this article you agree to the Terms of Service and the article's licence.

If a file you wish to view isn't highlighted, and is a text file (not binary), please let us know and we'll add colourisation support for it.

License

This article, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Share

About the Author

Harold Bamford
Software Developer (Senior) Thales Visionix
United States United States
No Biography provided

| Advertise | Privacy | Terms of Use | Mobile
Web03 | 2.8.141223.1 | Last Updated 23 Feb 2012
Article Copyright 2002 by Harold Bamford
Everything else Copyright © CodeProject, 1999-2014
Layout: fixed | fluid