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