// PXPerl.cpp: implementation of the CPerl class.
//
//////////////////////////////////////////////////////////////////////
#include "stdafx.h"
#include "PXPerl.h"
#include "resource.h"
#pragma comment(lib, "shlwapi.lib")
#pragma comment(lib, "PERL_CORE/perl58.lib")
// I don't know if the following is really necessary
#ifdef DEBUG
#define POP_DEBUG
#pragma push_macro("DEBUG")
#undef DEBUG
#endif
#include "PERL_CORE/config.h"
#include "PERL_CORE/EXTERN.h"
#include "PERL_CORE/perl.h"
#include "PERL_CORE/XSUB.h"
#ifdef POP_DEBUG
#pragma pop_macro("DEBUG")
#endif
#undef bool
#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
#include <io.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/stat.h>
#pragma warning(disable : 4706) // to be compiler-warning-level-4-safe
namespace PXPerl
{
//////////////////////////////////////////////////////////////////////
// globals
LPCSTR CPerlConfigFile::g_szOutputFormat = "\n\
# Variable: %s | Type: %s\n\
# Comment: %s\n\
\n\
%s = %s;\n\
";
LPCSTR CPerlConfigFile::g_szOutputFormatWithDefault = "\n\
# Variable: %s | Type: %s | Default Value: \"%s\"\n\
# Comment: %s\n\
\n\
%s = %s;\n\
";
CString CPerl::g_strExeDir;
//////////////////////////////////////////////////////////////////////
// defines
#define IS_LOADED (m_pMyPerl!=NULL)
#define IS_UNLOADED (m_pMyPerl==NULL)
#define SET_CONTEXT PERL_SET_CONTEXT((PerlInterpreter*)m_pMyPerl)
#define IS_INVALID_SOBJ(s) (s.m_nIndex < 0 || s.m_nIndex > m_nMaxPackageIndex || m_strAPackages.GetAt(s.m_nIndex).IsEmpty())
#define MAKE_SCOPE_VAR(s, var) \
if (IS_INVALID_SOBJ(s) || !var || !*var) \
return false; \
char beef[256]; \
if (var[0] == ':' && var[1] == ':') \
strcpy(beef, var + 2); \
else \
{ \
strcpy(beef, m_strAPackages.GetAt(s.m_nIndex)); \
strcat(beef, "::"); \
strcat(beef, var); \
} \
var = (const char*)beef;
#define COMMON_SET(s, var) \
if (IS_UNLOADED) return false; \
SET_CONTEXT; \
MAKE_SCOPE_VAR(s, var);
#define COMMON_GET(s, var) COMMON_SET(s, var)
//////////////////////////////////////////////////////////////////////
// utility
CString PXGetExeDir(void)
{
if (CPerl::g_strExeDir.IsEmpty())
{
TCHAR szPath[MAX_PATH];
if (GetModuleFileName(NULL, szPath, MAX_PATH))
{
PathRemoveFileSpec(szPath);
CPerl::g_strExeDir = (LPCTSTR)szPath;
}
}
return CPerl::g_strExeDir;
}
void PXPathAppend(CString &strPath, LPCSTR szAppend)
{
PathAppendA(strPath.GetBuffer(MAX_PATH), szAppend);
strPath.ReleaseBuffer();
}
void PXPerlErrorMsgBox(LPCSTR szText)
{
::MessageBoxA(AfxGetMainWnd()->GetSafeHwnd(), szText, "Perl Persistent Interpreter Error",
MB_OK | MB_ICONSTOP);
}
LPVOID PXReadPerlResource(int nResID, DWORD &dwSize)
{
HMODULE hModule = GetModuleHandle(NULL);
HRSRC hRes = FindResource(hModule,
MAKEINTRESOURCE(nResID), MAKEINTRESOURCE(RT_PERL));
if (!hRes)
return NULL;
dwSize = SizeofResource(hModule, hRes);
if (!dwSize)
return NULL;
HANDLE hResData = LoadResource(hModule, hRes);
if (!hResData)
return NULL;
return LockResource(hResData);
}
int PXGetFileSize(int fh)
{
int nPrevPos = _tell(fh);
_lseek(fh, 0, SEEK_SET);
int size = _lseek(fh, 0, SEEK_END);
_lseek(fh, nPrevPos, SEEK_SET);
return size;
}
bool PXReadFile(LPCSTR szFile, CString &strRead)
{
bool bRet = false;
int fh;
if ((fh = _open(szFile, _O_RDONLY | _O_BINARY)) == -1)
return false;
int size = PXGetFileSize(fh);
if (size > 0)
{
LPSTR sBuffer = strRead.GetBuffer(size + 8);
int nRead = _read(fh, (void*)sBuffer, size);
sBuffer[size] = 0;
strRead.ReleaseBuffer();
bRet = (nRead == size);
}
_close(fh);
return bRet;
}
bool PXWriteCreateFile(LPCSTR szFile, const CString &strWrite)
{
int fh;
if ((fh = _open(szFile, _O_WRONLY | _O_CREAT | _O_TRUNC | _O_BINARY, _S_IREAD | _S_IWRITE)) == -1)
return false;
int size = strWrite.GetLength();
bool bRet = (_write(fh, (const void*)LPCSTR(strWrite), size) == size);
_close(fh);
return bRet;
}
// that's tricky void *m_pMyPerl, huh?
bool PXPerlCallRetString(void *m_pMyPerl, LPCSTR szFunc, CString &strRet)
{
if (IS_LOADED)
{
SET_CONTEXT;
dSP;
bool ret = false;
int count;
ENTER ;
SAVETMPS;
PUSHMARK(SP);
PUTBACK;
count = call_pv(szFunc, G_EVAL | G_SCALAR);
SPAGAIN;
if (count != 1)
PXPerlErrorMsgBox((LPCSTR)SvPV_nolen(ERRSV));
else if (SvTRUE(ERRSV))
{
PXPerlErrorMsgBox((LPCSTR)SvPV_nolen(ERRSV));
POPs;
}
else
{
strRet = POPp;//(LPCSTR)SvPV_nolen(POPs);
ret = true;
}
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
return false;
}
bool PXPerlCall(void *m_pMyPerl, LPCSTR szFunc)
{
if (IS_LOADED)
{
char *args[] = { NULL };
SET_CONTEXT;
call_argv(szFunc, G_EVAL | G_DISCARD, args);
if (SvTRUE(ERRSV))
{
PXPerlErrorMsgBox((LPCSTR)SvPV_nolen(ERRSV));
return false;
}
return true;
}
return false;
}
//////////////////////////////////////////////////////////////////////
// Construction/Destruction
//////////////////////////////////////////////////////////////////////
CPerl::CPerl()
{
m_pMyPerl = NULL;
m_strAPackages.SetSize(3);
m_nMaxPackageIndex = 0;
m_bAutoEmpty = true;
}
CPerl::~CPerl()
{
Unload();
}
//////////////////////////////////////////////////////////////////////
EXTERN_C void boot_DynaLoader(pTHXo_ CV* cv);
EXTERN_C void
xs_init(pTHXo)
{
UNUSED_ALWAYS(my_perl); // compiler warning level 4... argh !
char *file = __FILE__;
dXSUB_SYS;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}
//////////////////////////////////////////////////////////////////////
bool CPerl::Load()
{
if (IS_UNLOADED)
{
bool bLoaded = false;
//////////////////////////////////////////////////////////////////
// NOTE: if you get an assert from below, that's because
// you missed something setting up this class in your project -
DWORD dwSize;
LPVOID lpData = PXReadPerlResource(IDR_PERLSISTENT, dwSize);
if (!lpData)
ASSERT(0);
//////////////////////////////////////////////////////////////////
LPSTR buffer = new CHAR[dwSize+8];
memcpy(buffer, lpData, dwSize);
buffer[dwSize] = 0;
char *embedding[] = { "", "-e", buffer };
int ret = 0;
if ((m_pMyPerl = (void*)perl_alloc()) == NULL)
{
PXPerlErrorMsgBox("Could not allocate memory for Perl !");
goto _return;
}
else
{
perl_construct((PerlInterpreter*)m_pMyPerl);
ret = perl_parse((PerlInterpreter*)m_pMyPerl, xs_init,
sizeof(*embedding) - 1, embedding, NULL);
if (ret)
goto _on_error;
else
{
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
ret = perl_run((PerlInterpreter*)m_pMyPerl);
if (ret)
goto _on_error;
else
{
// Make sure it's all right
char *args[] = { NULL };
int nCount = call_argv("test", G_EVAL | G_SCALAR, args);
if (nCount != 1 || SvTRUE(ERRSV))
goto _on_error;
else
bLoaded = true;
}
}
}
goto _return;
_on_error:
{
CString strErr("Error while running persistent interpreter ");
if (SvTRUE(ERRSV))
{
strErr += ":\n\n";
strErr += (LPCSTR)SvPV_nolen(ERRSV);
}
else
{
strErr += ".";
}
PXPerlErrorMsgBox(LPCSTR(strErr));
perl_destruct((PerlInterpreter*)m_pMyPerl);
perl_free((PerlInterpreter*)m_pMyPerl);
m_pMyPerl = NULL;
}
_return:
delete [] buffer;
return bLoaded;
}
return true;
}
void CPerl::Unload()
{
if (IS_LOADED)
{
try
{
SET_CONTEXT;
PL_perl_destruct_level = 0;
perl_destruct((PerlInterpreter*)m_pMyPerl);
perl_free((PerlInterpreter*)m_pMyPerl);
m_pMyPerl = NULL;
m_strAPackages.SetSize(0);
m_nMaxPackageIndex = 0;
m_strAPackages.SetSize(3);
}
catch (...)
{
TRACE("EXCEPTION: CPerl::Unload()\n");
}
}
}
CScript CPerl::Compile(LPCSTR szName, LPCSTR szScript)
{
CScript script;
if (IS_UNLOADED)
{
// Perl not loaded at this point
return script;
}
// check the script name (will be used as the perl package name)
if (!szName || !*szName || isdigit((int)*szName))
return NULL;
int len = (int)strlen(szName);
for (int i=0; i<len; i++)
{
if (!isalnum((int)szName[i]))
return NULL;
}
LPSTR sPackageName = new CHAR[len+1];
memcpy(sPackageName, szName, len);
sPackageName[len] = 0;
len = (int)strlen(szScript);
LPSTR sScript = new CHAR[len+1];
memcpy(sScript, szScript, len);
sScript[len] = 0;
char *args[] = { sPackageName, sScript, m_bAutoEmpty ? "1" : NULL, NULL };
SET_CONTEXT;
call_argv("compile", G_EVAL | G_DISCARD, args);
// calling with G_EVAL : can't get script errors with ERRSV
// calling without G_EVAL : in case of error, app crash risks, but we can grab script errors with ERRSV
delete [] sScript;
CString strPackageName((LPCSTR)sPackageName);
delete [] sPackageName;
if (SvTRUE(ERRSV))
{
PXPerlErrorMsgBox((LPCSTR)SvPV_nolen(ERRSV));
return script;
}
CString strErr;
if (GetSTDERR(strErr))
{
return script;
}
m_strAPackages.SetAtGrow(m_nMaxPackageIndex, strPackageName);
script.m_nIndex = m_nMaxPackageIndex;
m_nMaxPackageIndex++;
return script;
}
CScript CPerl::Compile(LPCSTR szName, const CPerlConfigFile& perlConfig)
{
return Compile(szName, LPCSTR(perlConfig.m_strOutput));
}
CScript CPerl::Compile(LPCSTR szName, int nResID)
{
CScript script;
DWORD dwSize;
LPVOID lpData = PXReadPerlResource(nResID, dwSize);
if (!lpData)
return NULL;
LPSTR buffer = new CHAR[dwSize+8];
memcpy(buffer, lpData, dwSize);
buffer[dwSize] = 0;
script = Compile(szName, (LPCSTR)buffer);
delete [] buffer;
return script;
}
CScript CPerl::CompileFile(LPCSTR szName, LPCSTR szFile)
{
CString strScript;
if (!PXReadFile(szFile, strScript))
return NULL;
return Compile(szName, strScript);
}
bool CPerl::Exec(const CScript& script)
{
if (IS_UNLOADED)
{
// Perl not loaded at this point
return false;
}
if (IS_INVALID_SOBJ(script))
return false;
char *args[] = { m_strAPackages.GetAt(script.m_nIndex).GetBuffer(0),
m_bAutoEmpty ? "1" : NULL, NULL };
SET_CONTEXT;
call_argv("execute", G_EVAL | G_DISCARD, args);
m_strAPackages.GetAt(script.m_nIndex).ReleaseBuffer();
if (SvTRUE(ERRSV))
{
PXPerlErrorMsgBox((LPCSTR)SvPV_nolen(ERRSV));
return false;
}
CString strErr;
if (GetSTDERR(strErr))
{
return false;
}
return true;
}
void CPerl::Clean(CScript& script)
{
if (IS_UNLOADED)
{
// Perl not loaded at this point
return;
}
if (IS_INVALID_SOBJ(script))
return;
char *args[] = { m_strAPackages.GetAt(script.m_nIndex).GetBuffer(0), NULL };
m_strAPackages.GetAt(script.m_nIndex).ReleaseBuffer();
SET_CONTEXT;
call_argv("clean", G_EVAL | G_DISCARD, args);
if (SvTRUE(ERRSV))
{
PXPerlErrorMsgBox((LPCSTR)SvPV_nolen(ERRSV));
return;
}
m_strAPackages.GetAt(script.m_nIndex).Empty();
}
bool CPerl::DoScript(LPCSTR szScript)
{
bool bRes = false;
CScript script = Compile("Temp", szScript);
if (script.IsValid())
{
bRes = Exec(script);
Clean(script);
}
return bRes;
}
bool CPerl::DoScript(const CPerlConfigFile& perlConfig)
{
bool bRes = false;
CScript script = Compile("Temp", perlConfig);
if (script.IsValid())
{
bRes = Exec(script);
Clean(script);
}
return bRes;
}
bool CPerl::DoFile(LPCSTR szFile)
{
bool bRes = false;
CScript script = CompileFile("Temp", szFile);
if (script.IsValid())
{
bRes = Exec(script);
Clean(script);
}
return bRes;
}
bool CPerl::DoScript(int nResID)
{
bool bRes = false;
CScript script = Compile("Temp", nResID);
if (script.IsValid())
{
bRes = Exec(script);
Clean(script);
}
return bRes;
}
bool CPerl::GetSTDERR(CString &strContents)
{
if (!PXPerlCallRetString(m_pMyPerl, "get_stderr", strContents))
return false;
return (strContents.IsEmpty()==0);
}
bool CPerl::GetSTDOUT(CString &strContents)
{
if (!PXPerlCallRetString(m_pMyPerl, "get_stdout", strContents))
return false;
return (strContents.IsEmpty()==0);
}
void CPerl::EmptySTDERR(void)
{
PXPerlCall(m_pMyPerl, "empty_stderr");
}
void CPerl::EmptySTDOUT(void)
{
PXPerlCall(m_pMyPerl, "empty_stdout");
}
void CPerl::EmptyOutputs(void)
{
PXPerlCall(m_pMyPerl, "empty_outputs");
}
void CPerl::SetAutoEmpty(bool bAuto)
{
m_bAutoEmpty = bAuto;
}
bool CPerl::SetInt(const CScript& script, LPCSTR szVariable, const int value)
{
COMMON_SET(script, szVariable);
//<CPerlWrap>
// Create the scalar if it doesn't exist, turn off spurious warnings
SV *v = get_sv(szVariable, true|GV_ADDMULTI);
if (!v) return false;
sv_setiv(v, value);
return true;
//</CPerlWrap>
}
bool CPerl::GetInt(const CScript& script, LPCSTR szVariable, int &value)
{
COMMON_SET(script, szVariable);
//<CPerlWrap>
SV *v = get_sv(szVariable, false); // false means don't create if it doesn't already exist
if(!v) return false;
value = SvIV(v);
return true;
//</CPerlWrap>
}
bool CPerl::SetFloat(const CScript& script, LPCSTR szVariable, const double value)
{
COMMON_SET(script, szVariable);
//<CPerlWrap>
SV *v = get_sv(szVariable, true|GV_ADDMULTI);
if (!v) return false;
sv_setnv(v, value);
return true;
//</CPerlWrap>
}
bool CPerl::GetFloat(const CScript& script, LPCSTR szVariable, double &value)
{
COMMON_GET(script, szVariable);
//<CPerlWrap>
SV *v = get_sv(szVariable, false);
if (!v) return false;
value = SvNV(v);
return true;
//</CPerlWrap>
}
bool CPerl::SetString(const CScript& script, LPCSTR szVariable, LPCSTR value)
{
COMMON_SET(script, szVariable);
//<CPerlWrap>
SV *v = get_sv(szVariable, true|GV_ADDMULTI);
if (!v) return false;
sv_setpv(v, value);
return true;
//</CPerlWrap>
}
bool CPerl::GetString(const CScript& script, LPCSTR szVariable, CString &value)
{
COMMON_GET(script, szVariable);
//<CPerlWrap>
SV *v = get_sv(szVariable, false);
if (!v) return false;
value = (LPCSTR)SvPV_nolen(v);
return true;
//</CPerlWrap>
}
bool CPerl::SetArray(const CScript& script, LPCSTR szVariable, const CStringArray &array,
bool bAppend)
{
COMMON_SET(script, szVariable);
//<CPerlWrap, highly modified>
AV *v = get_av(szVariable, true|GV_ADDMULTI);
if (!v)
return false;
if (!bAppend)
av_clear(v);
int len = av_len(v);
int nSize = (int)array.GetSize();
// Allocate memory
av_fill(v, len + nSize);
for (int i=0; i<nSize; i++)
{
len++;
SV *val = newSVpv((LPCSTR)array.GetAt(i), 0);
if (val)
av_store(v, len, val);
}
//</CPerlWrap>
return true;
}
bool CPerl::GetArray(const CScript& script, LPCSTR szVariable, CStringArray &array,
bool bAppend)
{
COMMON_GET(script, szVariable);
//<CPerlWrap, highly modified>
AV *v = get_av(szVariable, false);
if (!v)
return false;
if (!bAppend)
array.SetSize(0);
int len = av_len(v) + 1; // number of elements in array
/*
Note from VC++ doc :
Before using an array, use SetSize to establish its size and allocate memory for it. If you do not use SetSize, adding elements to your array causes it to be frequently reallocated and copied. Frequent reallocation and copying are inefficient and can fragment memory.
*/
int nSize = (int)array.GetSize();
array.SetSize(nSize + len);
for (int i=0; i<len; i++)
{
SV **val = av_fetch(v, i, 0); // 0 means to not change the value
if (!val)
return false;
array.SetAt(nSize + i, SvPV_nolen(*val));
}
//</CPerlWrap>
return true;
}
bool CPerl::SetHash(const CScript& script, LPCSTR szVariable,
const CMapStringToString &hash,
bool bAppend)
{
COMMON_SET(script, szVariable);
//<CPerlWrap>
HV *v = get_hv(szVariable, true|GV_ADDMULTI);
if(!v)
return false;
if (!bAppend)
hv_clear(v);
CString strKey;
CString strVal;
POSITION pos = hash.GetStartPosition();
while (pos)
{
hash.GetNextAssoc(pos, strKey, strVal);
SV *svVal = newSVpv(LPCSTR(strVal), 0);
if(!svVal)
return false;
hv_store(v, LPCSTR(strKey), strKey.GetLength(), svVal, 0);
}
//</CPerlWrap>
return true;
}
bool CPerl::GetHash(const CScript& script, LPCSTR szVariable,
CMapStringToString &hash, bool bAppend)
{
COMMON_GET(script, szVariable);
//<CPerlWrap, modified>
HV *v = get_hv(szVariable, false);
if(!v)
return false;
if (!bAppend)
hash.RemoveAll();
hv_iterinit(v); // get beginning iterator
HE *hashEntry; // pointer to current hashentry
I32 nKeyLen;
//char *buffer = new char[nKeyLen];
while (hashEntry = hv_iternext(v))
{
// Get the key
char *sKeyName = hv_iterkey(hashEntry, &nKeyLen);
if (!sKeyName)
return false;
SV *svVal = hv_iterval(v, hashEntry);
hash.SetAt((LPCSTR)sKeyName, svVal ? (LPCSTR)SvPV_nolen(svVal) : "");
}
//</CPerlWrap>
return true;
}
///////////////////////////////////////////////////////////////
// CPerlConfigFile
bool CPerlConfigFile::Flush(LPCSTR szFile, bool bReset)
{
bool bRet = true;
if (szFile)
bRet = PXWriteCreateFile(szFile, m_strOutput);
if (bReset)
m_strOutput.Empty();
return bRet;
}
void CPerlConfigFile::WriteInt(LPCSTR szVariable, int value, LPCSTR szComment, int *pnDefault)
{
CString strTemp;
char buf[64];
_itoa(value, buf, 10);
if (pnDefault)
{
char buf2[64];
_itoa(*pnDefault, buf2, 10);
strTemp.Format(g_szOutputFormatWithDefault, szVariable, "Integer", buf2, szComment, "$" + CString(szVariable), buf);
}
else
strTemp.Format(g_szOutputFormat, szVariable, "Integer", szComment, "$" + CString(szVariable), buf);
m_strOutput += strTemp;
}
void CPerlConfigFile::WriteBool(LPCSTR szVariable, bool value, LPCSTR szComment, bool *pbDefault)
{
CString strTemp;
char buf[64];
_itoa(value, buf, 10);
if (pbDefault)
{
char buf2[64];
_itoa(*pbDefault, buf2, 10);
strTemp.Format(g_szOutputFormatWithDefault, szVariable, "Boolean", buf2, szComment, "$" + CString(szVariable), buf);
}
else
strTemp.Format(g_szOutputFormat, szVariable, "Boolean", szComment, "$" + CString(szVariable), buf);
m_strOutput += strTemp;
}
void CPerlConfigFile::WriteFloat(LPCSTR szVariable, double value, LPCSTR szComment, double *pdDefault)
{
CString strTemp;
char buf[64];
_gcvt(value, 31, buf);
if (pdDefault)
{
char buf2[64];
_gcvt(*pdDefault, 31, buf2);
strTemp.Format(g_szOutputFormatWithDefault, szVariable, "Float", buf2, szComment, "$" + CString(szVariable), buf);
}
else
strTemp.Format(g_szOutputFormat, szVariable, "Float", szComment, "$" + CString(szVariable), buf);
m_strOutput += strTemp;
}
void CPerlConfigFile::WriteString(LPCSTR szVariable, LPCSTR value, LPCSTR szComment, char cDelim, CString *pstrDefault)
{
CString strTemp, strTemp2;
strTemp2.Format("q%c%s%c", cDelim, value, cDelim);
strTemp2.Replace("\\", "\\\\");
if (pstrDefault)
strTemp.Format(g_szOutputFormatWithDefault, szVariable, "String", LPCSTR(*pstrDefault), szComment, "$" + CString(szVariable), LPCSTR(strTemp2));
else
strTemp.Format(g_szOutputFormat, szVariable, "String", szComment, "$" + CString(szVariable), LPCSTR(strTemp2));
m_strOutput += strTemp;
}
void CPerlConfigFile::WriteStringArray(LPCSTR szVariable, CStringArray &array, LPCSTR szComment, char cDelim)
{
CString strTemp("(\n"), strTemp2;
int nSize = (int)array.GetSize();
for (int i=0; i<nSize; i++)
{
strTemp2.Format("\tq%c%s%c,\n", cDelim, array[i], cDelim);
strTemp2.Replace("\\", "\\\\");
strTemp += strTemp2;
}
strTemp += ")";
strTemp2.Format(g_szOutputFormat, szVariable, "Array of Strings", szComment, "@" + CString(szVariable), LPCSTR(strTemp));
m_strOutput += strTemp2;
}
}