Hi list,
I am writing a portal/application server in C++ using f.e. XSLT or perl
5.10.0 for the representation of the data.
Internally I'm using an own MT-XML implementation. I try to do this for the
platforms Win32, Linux and Solaris.
The presentation layer for perl uses embedded perl.
For every presentation (Service and Function depended) the script is being
stored in a own PerlInterpreter.
If a request has to be resolved by the perl-presentation (MT), this
PerlInterpreter will be cloned and processed (call_pv).
For interaction with the portal-server an object is created, holding the
data of the request and the result of the server side service call. I
defined different XS-functions for interaction with this object
(Service-calls, Streaming, Data evaluation and manipulation, and ...). On
Linux64 this works fine every time.
In Windows I can also call the XS-functions as often I want. The perl-script
will generate the correct result and will also return the correct result to
the caller. But there are different behaviours on destroying the Interpreter
instance.
Following happens:
Calling one XS function (returning xml-representation of the object) -> Perl
behaves as wanted
Calling this XS function two times -> Perl will be looping in destruction of
the initial PerlInterpreter in ~vmem.
Calling different XS functions like Streaming to browser, the cloned
PerlInterpreter corrupts the heap.
Does anybody knows a solution of this problem for Windows ?
Here's my c++ code:
#include <stdlib.h>
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
EXTERN_C void xs_init_base(pTHX);
EXTERN_C void xs_init_advanced(pTHX);
EXTERN_C void dl_init(pTHX);
#define PERL_USES_REF 1
//#define PERL_USES_XPUSH 1
/***************************************************************************
**/
cAPAction *action_get(pTHX_ SV *in)
{
//dVAR;
dXSARGS;
#ifdef PERL_USES_REF
if(SvROK(in))
{
if(SvTYPE(in) == SVt_RV)
{
SV *sv = (SV*)SvRV(in);
if(sv)
{
SV *pv = (SV*)SvRV(sv);
if(pv->sv_any)
{
return (cAPAction*)(pv->sv_any);
}
}
}
croak("Given pointer is not an action");
}
#else
if(SvIOK(in))
{
cAPAction *_pAction = INT2PTR(cAPAction*, SvIV(in));
return _pAction;
croak("Given pointer is not an action");
}
#endif
croak("Parameter can't be read");
return NULL;
}
// *** BEGIN OF xs FUNCTIONS
/***************************************************************************
**/
XS(sayHello)
{
//dVAR;
dXSARGS;
STRLEN len;
if(items != 1)
{
croak("Give exatly one parameter as string");
}
#ifdef PERL_USES_XPUSH
SP -= items;
#endif
string _sCallData = SvPV(ST(0), len);
string _sData = apSayHello(_sCallData);
if(_sData.size())
{
#ifdef PERL_USES_XPUSH
char *_pcRet = new char[_sData.size() + 1];
strncpy(_pcRet, _sData.c_str(), _sData.size());
_pcRet[_sData.size()] = 0;
SV *_pReturn = newSVpv(_pcRet, 0);
SvUTF8_on(_pReturn);
XPUSHs(sv_2mortal(_pReturn));
//XPUSHs(sv_2mortal(newSVpv(_pcRet, _sData.size() + 1)));
//XSRETURN_PV(_pcRet);
#else
ST(0) = sv_newmortal();
sv_setpv(ST(0), (const char *)_sData.c_str());
SvUTF8_on(ST(0));
#endif
XSRETURN(1);
PUTBACK;
}
else
{
croak("Parameter is not set");
}
}
/***************************************************************************
**/
XS(actionAsXml)
{
//dVAR;
dXSARGS;
if(items != 1)
{
croak("ap::actionAsXml takes one parameter (address of
action).");
}
#ifdef PERL_USES_XPUSH
SP -= items;
#endif
cAPAction *_pAction = action_get(aTHX_ ST(0));
if(_pAction)
{
string _sXml = apActionAsXml(_pAction);
if(_sXml.size())
{
#ifdef PERL_USES_XPUSH
char *_pcRet = new char[_sXml.size() + 1];
strncpy(_pcRet, _sXml.c_str(), _sXml.size());
_pcRet[_sXml.size()] = 0;
SV *_pReturn = newSVpv(_pcRet, 0);
SvUTF8_on(_pReturn);
XPUSHs(sv_2mortal(_pReturn));
//XPUSHs(sv_2mortal(newSVpv(_pcRet, _sXml.size() +
1)));
//XSRETURN_PV(_pcRet);
#else
ST(0) = sv_newmortal();
sv_setpv(ST(0), (const char *)_sXml.c_str());
SvUTF8_on(ST(0));
#endif
XSRETURN(1);
PUTBACK;
}
else
{
croak("action is empty");
}
}
else
{
croak("reference is not an action");
}
}
/***************************************************************************
**/
XS(streamToSender)
{
//dVAR;
dXSARGS;
STRLEN len;
if(items < 2)
{
croak("ap::stream needs two parameter. First is the address
of the action. Second is a hash or pairs of strings.");
}
#ifdef PERL_USES_XPUSH
SP -= items;
#endif
cAPAction *_pAction = action_get(aTHX_ ST(0));
if(_pAction)
{
tCallMap _oCallMap;
for(long _l=1;_l<items-1;_l+=2)
{
string _sKey = SvPV(ST(_l), len);
string _sValue = SvPV(ST(_l+1), len);
_oCallMap[_sKey] = _sValue;
}
int _iErrorcode = apStreamToSender(_pAction, _oCallMap);
#ifdef PERL_USES_XPUSH
SV *_pReturn = newSViv(_iErrorcode);
XPUSHs(sv_2mortal(_pReturn));
//XPUSHs(sv_2mortal(newSVpv(_pcRet, _sXml.size() +
1)));
//XSRETURN_IV(_iErrorcode);
#else
ST(0) = sv_newmortal();
sv_setiv(ST(0), _iErrorcode);
#endif
XSRETURN(1);
PUTBACK;
}
else
{
croak("first reference is not an action");
}
}
// *** END OF xs FUNCTIONS
/***************************************************************************
**/
void* createPerlFilter(const char *pcFilename, int bBase)
{
int argc = 0;
char **argv = NULL;
char **env = NULL;
PERL_SYS_INIT3(&argc, &argv, &env);
int _iArgc = 2;
char *_pcArgv[] = {"apFilter", (char*)pcFilename};
PerlInterpreter *_pPerlInterpreter = perl_alloc();
PERL_SET_CONTEXT(_pPerlInterpreter);
perl_construct(_pPerlInterpreter);
int _iError = perl_parse(_pPerlInterpreter, xs_init, _iArgc,
_pcArgv, (char**)NULL);
if(_iError)
{
perl_destruct(_pPerlInterpreter);
_pPerlInterpreter = NULL;
}
return _pPerlInterpreter;
}
/***************************************************************************
**/
void deletePerlFilter(void *pPerlInterpreter)
{
if(pPerlInterpreter)
{
PERL_SET_CONTEXT((PerlInterpreter*)pPerlInterpreter);
perl_destruct((PerlInterpreter*)pPerlInterpreter);
perl_free((PerlInterpreter*)pPerlInterpreter);
}
}
/***************************************************************************
**/
char* runPerlFilterAction(
void
*pPerlInterpreter,
cAPAction
*pAction,
const char
*pcFunctionName,
const char
*pcFile
)
{
char *_pcReturn = NULL;
try
{
if(pPerlInterpreter)
{
int _iStat = 0;
PerlInterpreter *my_perl =
perl_clone((PerlInterpreter*)pPerlInterpreter, CLONEf_COPY_STACKS /*|
CLONEf_KEEP_PTR_TABLE*/);
if(my_perl)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
#ifdef PERL_USES_REF
SV *_pTemp = newSVuv(PTR2UV(pAction));
_pTemp->sv_any = pAction;
SvREADONLY_on(_pTemp);
//SvREFCNT_inc(_pTemp);
SV *_pAction = newRV(_pTemp);
//SV *_pAction = newSVrv(_pTemp,
"cAPAction");
#else
SV *_pAction = newSViv(PTR2IV(pAction));
#endif
XPUSHs(sv_2mortal(_pAction));
PUTBACK;
_iStat = call_pv(pcFunctionName, G_SCALAR |
G_EVAL | G_KEEPERR);
if(SvTRUE(ERRSV))
{
STRLEN n_a;
char _pcTmp[1024];
#ifdef _WINDOWS
_snprintf(_pcTmp, 1023, "Perl error
\"%s\": %s", pcFile, SvPV(ERRSV, n_a));
#else
snprintf(_pcTmp, 1023, "Perl error
\"%s\": %s", pcFile, SvPV(ERRSV, n_a));
#endif
_pcReturn = new char[1024];
strcpy(_pcReturn, _pcTmp);
}
else if(_iStat)
{
SV *_pSV = NULL;
SPAGAIN;
_pSV = POPs;
SvUTF8_on(_pSV);
STRLEN _lLength = 0;
char *_pcTemp = SvPV(_pSV,
_lLength);
unsigned long _lTempLength =
strlen(_pcTemp);
_pcReturn = new char[_lTempLength +
1];
if(_pcReturn)
{
strncpy(_pcReturn, _pcTemp,
_lTempLength);
_pcReturn[_lTempLength] =
NULL;
}
PUTBACK;
}
FREETMPS;
LEAVE;
PERL_SET_CONTEXT(my_perl);
PL_perl_destruct_level = 0;
perl_destruct(my_perl);
perl_free(my_perl);
}
}
}
catch(...)
{
}
return _pcReturn;
}
/***************************************************************************
**/
void xs_init(pTHX)
{
//PERL_UNUSED_CONTEXT;
char *_pcFile = __FILE__;
dXSUB_SYS;
{
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader,
_pcFile);
//newXS("ap::callService", callService, _pcFile);
//newXS("ap::logToFile", logFile, _pcFile);
//newXS("ap::importXml", importXml, _pcFile);
//newXS("ap::exportXml", exportXml, _pcFile);
//newXS("ap::repository", repository, _pcFile);
newXS("ap::stream", streamToSender, _pcFile);
//newXS("ap::charset", setCharset, _pcFile);
//newXS("ap::message", message, _pcFile);
newXS("ap::actionAsXml", actionAsXml, _pcFile);
//newXS("ap::actionGetBaseParam", actionGetBaseParam,
_pcFile);
//newXS("ap::actionGetRequestParam", actionGetRequestParam,
_pcFile);
//newXS("ap::actionGetResponseParam",
actionGetResponseParam, _pcFile);
//newXS("ap::actionSetResponseParam",
actionSetResponseParam, _pcFile);
newXS("ap::sayhello", sayHello, _pcFile);
}
}
/***************************************************************************
**/
void dl_init(pTHX)
{
dTARG;
dSP;
SAVETMPS;
targ = sv_newmortal();
FREETMPS;
}
And the perl script:
use strict;
use warnings;
sub ap_presentation
{
my $action_addr = shift;
printf("Called script\n");
printf("Address: $action_addr\n");
my $sayhelloreturn = ap::sayhello(" hello ap");
printf("output: $sayhelloreturn\n");
my $sayhelloagain = ap::sayhello(" hello ap again");
printf("output: $sayhelloagain\n");
# if I call this one times all works fine on WIN
my $xmlAction = ap::actionAsXml(\$action_addr);
printf("\n$xmlAction\n");
printf("Address: $action_addr\n");
# if I call this the perl interpreter loops in ~vmem on WIN
my $testAction = ap::actionAsXml(\$action_addr);
printf("\n$testAction\n");
# if I use this the cloned interpreter ends in a heap corruption
my %callmap = ();
$callmap{"RESULT"} = "Kleiner Teststring zum Streamen";
$callmap{"ERRORCODE"} = "0";
$callmap{"CONTENTTYPE"} = "text/html";
$callmap{"CTYPE"} = "test";
$callmap{"PRESENTATION"} = "FALSE";
my $result = "Kleiner Teststring zum Streamen. Teil:";
for my $counter (1..10)
{
$callmap{"RESULT"} = "<HR>$result $counter\n";
my $errorcode = ap::stream(\$action_addr, %callmap);
printf("Streaming to sender returns value: $errorcode\n");
}
my $tmp_buf = $xmlAction;
$tmp_buf .= "\n<!--Added content by perlscript-->\n";
return $tmp_buf;
}
Kindly regards Michael
_______________________________________________
Perl-Win32-Users mailing list
Perl-Win32-Users@listserv.ActiveState.com
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs
