summaryrefslogtreecommitdiffstats
path: root/src/modules/perlcore
diff options
context:
space:
mode:
Diffstat (limited to 'src/modules/perlcore')
-rw-r--r--src/modules/perlcore/KVIrc.xs139
-rw-r--r--src/modules/perlcore/Makefile.am23
-rw-r--r--src/modules/perlcore/libkviperlcore.cpp414
-rw-r--r--src/modules/perlcore/perlcoreinterface.h59
-rw-r--r--src/modules/perlcore/ppport.h540
-rw-r--r--src/modules/perlcore/typemap313
-rw-r--r--src/modules/perlcore/xs.inc277
7 files changed, 1765 insertions, 0 deletions
diff --git a/src/modules/perlcore/KVIrc.xs b/src/modules/perlcore/KVIrc.xs
new file mode 100644
index 00000000..37b040cf
--- /dev/null
+++ b/src/modules/perlcore/KVIrc.xs
@@ -0,0 +1,139 @@
+MODULE = KVIrc PACKAGE = KVIrc
+
+void echo(text,colorset = 0,windowid = 0)
+ char * text
+ int colorset
+ char * windowid
+ CODE:
+ if(g_pCurrentKvsContext && text)
+ {
+ KviWindow * pWnd;
+ if(windowid)
+ {
+ pWnd = g_pApp->findWindow(windowid);
+ if(!pWnd)pWnd = g_pCurrentKvsContext->window();
+ } else {
+ pWnd = g_pCurrentKvsContext->window();
+ }
+ pWnd->outputNoFmt(colorset,QString::fromUtf8(text));
+ }
+
+void say(text,windowid = 0)
+ char * text
+ char * windowid
+ CODE:
+ if(g_pCurrentKvsContext && text)
+ {
+ KviWindow * pWnd;
+ if(windowid)
+ {
+ pWnd = g_pApp->findWindow(windowid);
+ if(!pWnd)pWnd = g_pCurrentKvsContext->window();
+ } else {
+ pWnd = g_pCurrentKvsContext->window();
+ }
+ QString tmp = QString::fromUtf8(text);
+ KviUserInput::parse(tmp,pWnd);
+ }
+
+void warning(text)
+ char * text
+ CODE:
+ if((!g_bExecuteQuiet) && g_pCurrentKvsContext)
+ g_pCurrentKvsContext->warning(text);
+
+void internalWarning(text)
+ char * text
+ CODE:
+ if(!g_bExecuteQuiet)
+ g_lWarningList.append(QString(text));
+
+
+char * getLocal(varname)
+ char * varname
+ CODE:
+ QString tmp;
+ KviStr hack;
+ if(g_pCurrentKvsContext)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->localVariables()->find(varname);
+ if(pVar)
+ {
+ pVar->asString(tmp);
+ hack = tmp;
+ RETVAL = hack.ptr();
+ } else RETVAL = "";
+ }
+ OUTPUT:
+ RETVAL
+
+void setLocal(varname,value)
+ char * varname
+ char * value
+ CODE:
+ if(g_pCurrentKvsContext)
+ {
+ if(value && *value)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->localVariables()->get(varname);
+ pVar->setString(value);
+ } else {
+ g_pCurrentKvsContext->localVariables()->unset(varname);
+ }
+ }
+
+char * getGlobal(varname)
+ char * varname
+ CODE:
+ QString tmp;
+ KviStr hack;
+ if(g_pCurrentKvsContext)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->globalVariables()->find(varname);
+ if(pVar)
+ {
+ pVar->asString(tmp);
+ hack = tmp;
+ RETVAL = hack.ptr();
+ } else RETVAL = "";
+ }
+ OUTPUT:
+ RETVAL
+
+void setGlobal(varname,value)
+ char * varname
+ char * value
+ CODE:
+ if(g_pCurrentKvsContext)
+ {
+ if(value && *value)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->globalVariables()->get(varname);
+ pVar->setString(value);
+ } else {
+ g_pCurrentKvsContext->localVariables()->unset(varname);
+ }
+ }
+
+
+char * eval(code)
+ char * code
+ CODE:
+ if(g_pCurrentKvsContext && code)
+ {
+ KviKvsVariant ret;
+ if(KviKvsScript::run(QString::fromUtf8(code),g_pCurrentKvsContext->window(),0,&ret))
+ {
+ QString tmp;
+ ret.asString(tmp);
+ g_szLastReturnValue = tmp;
+ } else {
+ g_szLastReturnValue = "";
+ }
+ RETVAL = g_szLastReturnValue.ptr();
+ } else {
+ RETVAL = "";
+ }
+ OUTPUT:
+ RETVAL
+
diff --git a/src/modules/perlcore/Makefile.am b/src/modules/perlcore/Makefile.am
new file mode 100644
index 00000000..a153262c
--- /dev/null
+++ b/src/modules/perlcore/Makefile.am
@@ -0,0 +1,23 @@
+###############################################################################
+# KVirc IRC client Makefile - 10.03.2000 Szymon Stefanek <stefanek@tin.it>
+###############################################################################
+
+AM_CPPFLAGS = -I$(SS_TOPSRCDIR)/src/kvilib/include/ -I$(SS_TOPSRCDIR)/src/kvirc/include/ \
+$(SS_INCDIRS) $(SS_CPPFLAGS) -DGLOBAL_KVIRC_DIR=\"$(globalkvircdir)\" $(SS_PERL_CCFLAGS)
+
+pluglib_LTLIBRARIES = libkviperlcore.la
+
+libkviperlcore_la_LDFLAGS = -module -avoid-version $(SS_LDFLAGS) $(SS_LIBDIRS) $(SS_PERL_LDFLAGS)
+
+libkviperlcore_la_SOURCES = libkviperlcore.cpp
+libkviperlcore_la_LIBADD = $(SS_LIBLINK) ../../kvilib/build/libkvilib.la
+
+noinst_HEADERS = perlcoreinterface.h
+
+EXTRA_DIST = KVIrc.xs ppport.h xs.inc typemap
+
+%.moc: %.h
+ $(SS_QT_MOC) $< -o $@
+
+xs:
+ xsubpp -noversioncheck -C++ -noprototypes KVIrc.xs > xs.inc
diff --git a/src/modules/perlcore/libkviperlcore.cpp b/src/modules/perlcore/libkviperlcore.cpp
new file mode 100644
index 00000000..a9196219
--- /dev/null
+++ b/src/modules/perlcore/libkviperlcore.cpp
@@ -0,0 +1,414 @@
+//=============================================================================
+//
+// 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) 2001 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 opinion) 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 "kvi_module.h"
+#include "kvi_settings.h"
+#include "kvi_locale.h"
+#include "kvi_out.h"
+#include "kvi_window.h"
+#include "kvi_app.h"
+
+#include "kvi_kvs_script.h"
+#include "kvi_kvs_variant.h"
+#include "kvi_userinput.h"
+#include "kvi_qcstring.h"
+#include "kvi_pointerhashtable.h"
+
+#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 :)
+
+#ifdef COMPILE_PERL_SUPPORT
+ #include <EXTERN.h>
+ #include <perl.h>
+ #include <XSUB.h>
+
+ #include "ppport.h"
+
+ #include "kvi_kvs_runtimecontext.h"
+
+ static KviKvsRunTimeContext * g_pCurrentKvsContext = 0;
+ static bool g_bExecuteQuiet = false;
+ static KviStr g_szLastReturnValue("");
+ static QStringList g_lWarningList;
+
+ #include "xs.inc"
+#endif // COMPILE_PERL_SUPPORT
+
+// perl redefines bool :///
+#ifdef bool
+ #undef bool
+#endif
+
+#ifdef COMPILE_PERL_SUPPORT
+
+#include "perlcoreinterface.h"
+
+// 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(){ return m_szContextName; };
+protected:
+ QString svToQString(SV * sv);
+};
+
+KviPerlInterpreter::KviPerlInterpreter(const QString &szContextName)
+{
+ m_szContextName = szContextName;
+ m_pInterpreter = 0;
+}
+
+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.
+extern "C" void boot_DynaLoader(pTHX_ CV* cv);
+
+extern "C" void xs_init(pTHX)
+{
+ char *file = __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();
+ m_pInterpreter = perl_alloc();
+ if(!m_pInterpreter)return false;
+ PERL_SET_CONTEXT(m_pInterpreter);
+ PL_perl_destruct_level = 1;
+ perl_construct(m_pInterpreter);
+ char * daArgs[] = { "yo", "-e", "0", "-w" };
+ perl_parse(m_pInterpreter,xs_init,4,daArgs,NULL);
+ 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
+
+ KviQString::sprintf(
+ szInitCode,
+ "{\n" \
+ "package KVIrc;\n" \
+ "require Exporter;\n" \
+ "our @ISA = qw(Exporter);\n" \
+ "1;\n" \
+ "}\n" \
+ "$g_szContext = \"%Q\";\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",
+ &m_szContextName);
+
+ eval_pv(szInitCode.utf8().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 = 0;
+}
+
+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","perlcore");
+ return false;
+ }
+
+ g_lWarningList.clear();
+
+ KviQCString szUtf8 = szCode.utf8();
+ 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(QStringList::Iterator it = args.begin();it != args.end();++it)
+ {
+ QString tmp = *it;
+ const char * val = tmp.utf8().data();
+ if(val)
+ {
+ pArg = newSVpv(val,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 = 0;
+
+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 0;
+ }
+ 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 * m,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 * m)
+{
+#ifdef COMPILE_PERL_SUPPORT
+ g_pInterpreters = new KviPointerHashTable<QString,KviPerlInterpreter>(17,false);
+ g_pInterpreters->setAutoDelete(false);
+ return true;
+#else // !COMPILE_PERL_SUPPORT
+ return false;
+#endif // !COMPILE_PERL_SUPPORT
+}
+
+static bool perlcore_module_cleanup(KviModule *m)
+{
+#ifdef COMPILE_PERL_SUPPORT
+ perlcore_destroy_all_interpreters();
+ delete g_pInterpreters;
+ g_pInterpreters = 0;
+#endif // COMPILE_PERL_SUPPORT
+ return true;
+}
+
+static bool perlcore_module_can_unload(KviModule *m)
+{
+#ifdef COMPILE_PERL_SUPPORT
+ return (g_pInterpreters->count() == 0);
+#endif // COMPILE_PERL_SUPPORT
+ return true;
+}
+
+KVIRC_MODULE(
+ "Perl", // module name
+ "1.0.0", // module version
+ "Copyright (C) 2004 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
+)
diff --git a/src/modules/perlcore/perlcoreinterface.h b/src/modules/perlcore/perlcoreinterface.h
new file mode 100644
index 00000000..a7ceb1fc
--- /dev/null
+++ b/src/modules/perlcore/perlcoreinterface.h
@@ -0,0 +1,59 @@
+#ifndef _PERLCOREINTERFACE_H_
+#define _PERLCOREINTERFACE_H_
+
+//=============================================================================
+//
+// File : perlcoreinterface.h
+// 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) 2001 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 opinion) 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 "kvi_settings.h"
+#include "kvi_qstring.h"
+#include "kvi_kvs_runtimecontext.h"
+
+#include <qstringlist.h>
+
+
+#define KVI_PERLCORECTRLCOMMAND_EXECUTE "execute"
+
+typedef struct _KviPerlCoreCtrlCommand_execute
+{
+ unsigned int uSize;
+ KviKvsRunTimeContext * pKvsContext;
+ QString szContext;
+ QString szCode;
+ bool bExitOk;
+ QString szRetVal;
+ QString szError;
+ QStringList lWarnings;
+ QStringList lArgs;
+ bool bQuiet;
+} KviPerlCoreCtrlCommand_execute;
+
+#define KVI_PERLCORECTRLCOMMAND_DESTROY "destroy"
+
+typedef struct _KviPerlCoreCtrlCommand_destroy
+{
+ unsigned int uSize;
+ QString szContext;
+} KviPerlCoreCtrlCommand_destroy;
+
+#endif // !_PERLCOREINTERFACE_H_
diff --git a/src/modules/perlcore/ppport.h b/src/modules/perlcore/ppport.h
new file mode 100644
index 00000000..2a802132
--- /dev/null
+++ b/src/modules/perlcore/ppport.h
@@ -0,0 +1,540 @@
+
+/* ppport.h -- Perl/Pollution/Portability Version 2.0002
+ *
+ * Automatically Created by Devel::PPPort on Tue Jul 13 13:16:39 2004
+ *
+ * Do NOT edit this file directly! -- Edit PPPort.pm instead.
+ *
+ * Version 2.x, Copyright (C) 2001, Paul Marquess.
+ * Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+ * This code may be used and distributed under the same license as any
+ * version of Perl.
+ *
+ * This version of ppport.h is designed to support operation with Perl
+ * installations back to 5.004, and has been tested up to 5.8.0.
+ *
+ * If this version of ppport.h is failing during the compilation of this
+ * module, please check if a newer version of Devel::PPPort is available
+ * on CPAN before sending a bug report.
+ *
+ * If you are using the latest version of Devel::PPPort and it is failing
+ * during compilation of this module, please send a report to perlbug@perl.com
+ *
+ * Include all following information:
+ *
+ * 1. The complete output from running "perl -V"
+ *
+ * 2. This file.
+ *
+ * 3. The name & version of the module you were trying to build.
+ *
+ * 4. A full log of the build that failed.
+ *
+ * 5. Any other information that you think could be relevant.
+ *
+ *
+ * For the latest version of this code, please retreive the Devel::PPPort
+ * module from CPAN.
+ *
+ */
+
+/*
+ * In order for a Perl extension module to be as portable as possible
+ * across differing versions of Perl itself, certain steps need to be taken.
+ * Including this header is the first major one, then using dTHR is all the
+ * appropriate places and using a PL_ prefix to refer to global Perl
+ * variables is the second.
+ *
+ */
+
+
+/* If you use one of a few functions that were not present in earlier
+ * versions of Perl, please add a define before the inclusion of ppport.h
+ * for a static include, or use the GLOBAL request in a single module to
+ * produce a global definition that can be referenced from the other
+ * modules.
+ *
+ * Function: Static define: Extern define:
+ * newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+ *
+ */
+
+
+/* To verify whether ppport.h is needed for your module, and whether any
+ * special defines should be used, ppport.h can be run through Perl to check
+ * your source code. Simply say:
+ *
+ * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc]
+ *
+ * The result will be a list of patches suggesting changes that should at
+ * least be acceptable, if not necessarily the most efficient solution, or a
+ * fix for all possible problems. It won't catch where dTHR is needed, and
+ * doesn't attempt to account for global macro or function definitions,
+ * nested includes, typemaps, etc.
+ *
+ * In order to test for the need of dTHR, please try your module under a
+ * recent version of Perl that has threading compiled-in.
+ *
+ */
+
+
+/*
+#!/usr/bin/perl
+@ARGV = ("*.xs") if !@ARGV;
+%badmacros = %funcs = %macros = (); $replace = 0;
+foreach (<DATA>) {
+ $funcs{$1} = 1 if /Provide:\s+(\S+)/;
+ $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
+ $replace = $1 if /Replace:\s+(\d+)/;
+ $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
+ $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
+}
+foreach $filename (map(glob($_),@ARGV)) {
+ unless (open(IN, "<$filename")) {
+ warn "Unable to read from $file: $!\n";
+ next;
+ }
+ print "Scanning $filename...\n";
+ $c = ""; while (<IN>) { $c .= $_; } close(IN);
+ $need_include = 0; %add_func = (); $changes = 0;
+ $has_include = ($c =~ /#.*include.*ppport/m);
+
+ foreach $func (keys %funcs) {
+ if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
+ if ($c !~ /\b$func\b/m) {
+ print "If $func isn't needed, you don't need to request it.\n" if
+ $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
+ } else {
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ } else {
+ if ($c =~ /\b$func\b/m) {
+ $add_func{$func} =1 ;
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ if (not $need_include) {
+ foreach $macro (keys %macros) {
+ if ($c =~ /\b$macro\b/m) {
+ print "Uses $macro\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ foreach $badmacro (keys %badmacros) {
+ if ($c =~ /\b$badmacro\b/m) {
+ $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
+ print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
+ $need_include = 1;
+ }
+ }
+
+ if (scalar(keys %add_func) or $need_include != $has_include) {
+ if (!$has_include) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
+ "#include \"ppport.h\"\n";
+ $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
+ } elsif (keys %add_func) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
+ $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
+ }
+ if (!$need_include) {
+ print "Doesn't seem to need ppport.h.\n";
+ $c =~ s/^.*#.*include.*ppport.*\n//m;
+ }
+ $changes++;
+ }
+
+ if ($changes) {
+ open(OUT,">/tmp/ppport.h.$$");
+ print OUT $c;
+ close(OUT);
+ open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
+ while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
+ close(DIFF);
+ unlink("/tmp/ppport.h.$$");
+ } else {
+ print "Looks OK\n";
+ }
+}
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# include "patchlevel.h"
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_dowarn dowarn
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfpv rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifdef HASATTRIBUTE
+# if defined(__GNUC__) && defined(__cplusplus)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define NOOP (void)0
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+
+#ifndef dTHX
+# define dTHX dNOOP
+# define dTHXa(x) dNOOP
+# define dTHXoa(x) dNOOP
+#endif
+
+#ifndef pTHX
+# define pTHX void
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef UVSIZE
+# define UVSIZE IVSIZE
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+
+#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+#else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+#endif
+#define NUM2PTR(any,d) (any)(PTRV)(d)
+#define PTR2IV(p) INT2PTR(IV,p)
+#define PTR2UV(p) INT2PTR(UV,p)
+#define PTR2NV(p) NUM2PTR(NV,p)
+#if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+#else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+#endif
+
+#endif /* !INT2PTR */
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB(HV * stash, char * name, SV *sv);
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+#ifndef IVdf
+# if IVSIZE == LONGSIZE
+# define IVdf "ld"
+# define UVuf "lu"
+# define UVof "lo"
+# define UVxf "lx"
+# define UVXf "lX"
+# else
+# if IVSIZE == INTSIZE
+# define IVdf "d"
+# define UVuf "u"
+# define UVof "o"
+# define UVxf "x"
+# define UVXf "X"
+# endif
+# endif
+#endif
+
+#ifndef NVef
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
+ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
+# define NVef PERL_PRIeldbl
+# define NVff PERL_PRIfldbl
+# define NVgf PERL_PRIgldbl
+# else
+# define NVef "e"
+# define NVff "f"
+# define NVgf "g"
+# endif
+#endif
+
+#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
+# define AvFILLp AvFILL
+#endif
+
+#ifdef SvPVbyte
+# if PERL_REVISION == 5 && PERL_VERSION < 7
+ /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
+# undef SvPVbyte
+# define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
+ static char *
+ my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
+ {
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
+ }
+# endif
+#else
+# define SvPVbyte SvPV
+#endif
+
+#endif /* _P_P_PORTABILITY_H_ */
+
+/* End of File ppport.h */
diff --git a/src/modules/perlcore/typemap b/src/modules/perlcore/typemap
new file mode 100644
index 00000000..1124eb64
--- /dev/null
+++ b/src/modules/perlcore/typemap
@@ -0,0 +1,313 @@
+# basic C types
+int T_IV
+unsigned T_UV
+unsigned int T_UV
+long T_IV
+unsigned long T_UV
+short T_IV
+unsigned short T_UV
+char T_CHAR
+unsigned char T_U_CHAR
+char * T_PV
+unsigned char * T_PV
+const char * T_PV
+caddr_t T_PV
+wchar_t * T_PV
+wchar_t T_IV
+bool_t T_IV
+size_t T_UV
+ssize_t T_IV
+time_t T_NV
+unsigned long * T_OPAQUEPTR
+char ** T_PACKEDARRAY
+void * T_PTR
+Time_t * T_PV
+SV * T_SV
+SVREF T_SVREF
+AV * T_AVREF
+HV * T_HVREF
+CV * T_CVREF
+
+IV T_IV
+UV T_UV
+NV T_NV
+I32 T_IV
+I16 T_IV
+I8 T_IV
+STRLEN T_UV
+U32 T_U_LONG
+U16 T_U_SHORT
+U8 T_UV
+Result T_U_CHAR
+Boolean T_BOOL
+float T_FLOAT
+double T_DOUBLE
+SysRet T_SYSRET
+SysRetLong T_SYSRET
+FILE * T_STDIO
+PerlIO * T_INOUT
+FileHandle T_PTROBJ
+InputStream T_IN
+InOutStream T_INOUT
+OutputStream T_OUT
+bool T_BOOL
+
+#############################################################################
+INPUT
+T_SV
+ $var = $arg
+T_SVREF
+ if (SvROK($arg))
+ $var = (SV*)SvRV($arg);
+ else
+ Perl_croak(aTHX_ \"$var is not a reference\")
+T_AVREF
+ if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV)
+ $var = (AV*)SvRV($arg);
+ else
+ Perl_croak(aTHX_ \"$var is not an array reference\")
+T_HVREF
+ if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV)
+ $var = (HV*)SvRV($arg);
+ else
+ Perl_croak(aTHX_ \"$var is not a hash reference\")
+T_CVREF
+ if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV)
+ $var = (CV*)SvRV($arg);
+ else
+ Perl_croak(aTHX_ \"$var is not a code reference\")
+T_SYSRET
+ $var NOT IMPLEMENTED
+T_UV
+ $var = ($type)SvUV($arg)
+T_IV
+ $var = ($type)SvIV($arg)
+T_INT
+ $var = (int)SvIV($arg)
+T_ENUM
+ $var = ($type)SvIV($arg)
+T_BOOL
+ $var = (bool)SvTRUE($arg)
+T_U_INT
+ $var = (unsigned int)SvUV($arg)
+T_SHORT
+ $var = (short)SvIV($arg)
+T_U_SHORT
+ $var = (unsigned short)SvUV($arg)
+T_LONG
+ $var = (long)SvIV($arg)
+T_U_LONG
+ $var = (unsigned long)SvUV($arg)
+T_CHAR
+ $var = (char)*SvPV_nolen($arg)
+T_U_CHAR
+ $var = (unsigned char)SvUV($arg)
+T_FLOAT
+ $var = (float)SvNV($arg)
+T_NV
+ $var = ($type)SvNV($arg)
+T_DOUBLE
+ $var = (double)SvNV($arg)
+T_PV
+ $var = ($type)SvPV_nolen($arg)
+T_PTR
+ $var = INT2PTR($type,SvIV($arg))
+T_PTRREF
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ Perl_croak(aTHX_ \"$var is not a reference\")
+T_REF_IV_REF
+ if (sv_isa($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = *INT2PTR($type *, tmp);
+ }
+ else
+ Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
+T_REF_IV_PTR
+ if (sv_isa($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
+T_PTROBJ
+ if (sv_derived_from($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
+T_PTRDESC
+ if (sv_isa($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ ${type}_desc = (\U${type}_DESC\E*) tmp;
+ $var = ${type}_desc->ptr;
+ }
+ else
+ Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
+T_REFREF
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = *INT2PTR($type,tmp);
+ }
+ else
+ Perl_croak(aTHX_ \"$var is not a reference\")
+T_REFOBJ
+ if (sv_isa($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = *INT2PTR($type,tmp);
+ }
+ else
+ Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
+T_OPAQUE
+ $var = *($type *)SvPV_nolen($arg)
+T_OPAQUEPTR
+ $var = ($type)SvPV_nolen($arg)
+T_PACKED
+ $var = XS_unpack_$ntype($arg)
+T_PACKEDARRAY
+ $var = XS_unpack_$ntype($arg)
+T_CALLBACK
+ $var = make_perl_cb_$type($arg)
+T_ARRAY
+ U32 ix_$var = $argoff;
+ $var = $ntype(items -= $argoff);
+ while (items--) {
+ DO_ARRAY_ELEM;
+ ix_$var++;
+ }
+ /* this is the number of elements in the array */
+ ix_$var -= $argoff
+T_STDIO
+ $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
+T_IN
+ $var = IoIFP(sv_2io($arg))
+T_INOUT
+ $var = IoIFP(sv_2io($arg))
+T_OUT
+ $var = IoOFP(sv_2io($arg))
+#############################################################################
+OUTPUT
+T_SV
+ $arg = $var;
+T_SVREF
+ $arg = newRV((SV*)$var);
+T_AVREF
+ $arg = newRV((SV*)$var);
+T_HVREF
+ $arg = newRV((SV*)$var);
+T_CVREF
+ $arg = newRV((SV*)$var);
+T_IV
+ sv_setiv($arg, (IV)$var);
+T_UV
+ sv_setuv($arg, (UV)$var);
+T_INT
+ sv_setiv($arg, (IV)$var);
+T_SYSRET
+ if ($var != -1) {
+ if ($var == 0)
+ sv_setpvn($arg, "0 but true", 10);
+ else
+ sv_setiv($arg, (IV)$var);
+ }
+T_ENUM
+ sv_setiv($arg, (IV)$var);
+T_BOOL
+ $arg = boolSV($var);
+T_U_INT
+ sv_setuv($arg, (UV)$var);
+T_SHORT
+ sv_setiv($arg, (IV)$var);
+T_U_SHORT
+ sv_setuv($arg, (UV)$var);
+T_LONG
+ sv_setiv($arg, (IV)$var);
+T_U_LONG
+ sv_setuv($arg, (UV)$var);
+T_CHAR
+ sv_setpvn($arg, (char *)&$var, 1);
+T_U_CHAR
+ sv_setuv($arg, (UV)$var);
+T_FLOAT
+ sv_setnv($arg, (double)$var);
+T_NV
+ sv_setnv($arg, (NV)$var);
+T_DOUBLE
+ sv_setnv($arg, (double)$var);
+T_PV
+ sv_setpv((SV*)$arg, $var);
+T_PTR
+ sv_setiv($arg, PTR2IV($var));
+T_PTRREF
+ sv_setref_pv($arg, Nullch, (void*)$var);
+T_REF_IV_REF
+ sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
+T_REF_IV_PTR
+ sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+T_PTROBJ
+ sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+T_PTRDESC
+ sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
+T_REFREF
+ NOT_IMPLEMENTED
+T_REFOBJ
+ NOT IMPLEMENTED
+T_OPAQUE
+ sv_setpvn($arg, (char *)&$var, sizeof($var));
+T_OPAQUEPTR
+ sv_setpvn($arg, (char *)$var, sizeof(*$var));
+T_PACKED
+ XS_pack_$ntype($arg, $var);
+T_PACKEDARRAY
+ XS_pack_$ntype($arg, $var, count_$ntype);
+T_DATAUNIT
+ sv_setpvn($arg, $var.chp(), $var.size());
+T_CALLBACK
+ sv_setpvn($arg, $var.context.value().chp(),
+ $var.context.value().size());
+T_ARRAY
+ {
+ U32 ix_$var;
+ EXTEND(SP,size_$var);
+ for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
+ ST(ix_$var) = sv_newmortal();
+ DO_ARRAY_ELEM
+ }
+ }
+T_STDIO
+ {
+ GV *gv = newGVgen("$Package");
+ PerlIO *fp = PerlIO_importFILE($var,0);
+ if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
+ sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ else
+ $arg = &PL_sv_undef;
+ }
+T_IN
+ {
+ GV *gv = newGVgen("$Package");
+ if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
+ sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ else
+ $arg = &PL_sv_undef;
+ }
+T_INOUT
+ {
+ GV *gv = newGVgen("$Package");
+ if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
+ sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ else
+ $arg = &PL_sv_undef;
+ }
+T_OUT
+ {
+ GV *gv = newGVgen("$Package");
+ if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
+ sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ else
+ $arg = &PL_sv_undef;
+ }
diff --git a/src/modules/perlcore/xs.inc b/src/modules/perlcore/xs.inc
new file mode 100644
index 00000000..5c31cb19
--- /dev/null
+++ b/src/modules/perlcore/xs.inc
@@ -0,0 +1,277 @@
+/*
+ * This file was generated automatically by xsubpp version 1.9508 from the
+ * contents of KVIrc.xs. Do not edit this file, edit KVIrc.xs instead.
+ *
+ * ANY CHANGES MADE HERE WILL BE LOST!
+ *
+ */
+
+#line 1 "KVIrc.xs"
+#line 11 "KVIrc.c"
+XS(XS_KVIrc_echo); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_echo)
+{
+ dXSARGS;
+ if (items < 1 || items > 3)
+ Perl_croak(aTHX_ "Usage: KVIrc::echo(text, colorset = 0, windowid = 0)");
+ {
+ char * text = (char *)SvPV_nolen(ST(0));
+ int colorset;
+ char * windowid;
+
+ if (items < 2)
+ colorset = 0;
+ else {
+ colorset = (int)SvIV(ST(1));
+ }
+
+ if (items < 3)
+ windowid = 0;
+ else {
+ windowid = (char *)SvPV_nolen(ST(2));
+ }
+#line 8 "KVIrc.xs"
+ if(g_pCurrentKvsContext && text)
+ {
+ KviWindow * pWnd;
+ if(windowid)
+ {
+ pWnd = g_pApp->findWindow(windowid);
+ if(!pWnd)pWnd = g_pCurrentKvsContext->window();
+ } else {
+ pWnd = g_pCurrentKvsContext->window();
+ }
+ pWnd->outputNoFmt(colorset,QString::fromUtf8(text));
+ }
+#line 47 "KVIrc.c"
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(XS_KVIrc_say); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_say)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ Perl_croak(aTHX_ "Usage: KVIrc::say(text, windowid = 0)");
+ {
+ char * text = (char *)SvPV_nolen(ST(0));
+ char * windowid;
+
+ if (items < 2)
+ windowid = 0;
+ else {
+ windowid = (char *)SvPV_nolen(ST(1));
+ }
+#line 25 "KVIrc.xs"
+ if(g_pCurrentKvsContext && text)
+ {
+ KviWindow * pWnd;
+ if(windowid)
+ {
+ pWnd = g_pApp->findWindow(windowid);
+ if(!pWnd)pWnd = g_pCurrentKvsContext->window();
+ } else {
+ pWnd = g_pCurrentKvsContext->window();
+ }
+ QString tmp = QString::fromUtf8(text);
+ KviUserInput::parse(tmp,pWnd);
+ }
+#line 81 "KVIrc.c"
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(XS_KVIrc_warning); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_warning)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: KVIrc::warning(text)");
+ {
+ char * text = (char *)SvPV_nolen(ST(0));
+#line 42 "KVIrc.xs"
+ if((!g_bExecuteQuiet) && g_pCurrentKvsContext)
+ g_pCurrentKvsContext->warning(text);
+#line 97 "KVIrc.c"
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(XS_KVIrc_internalWarning); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_internalWarning)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: KVIrc::internalWarning(text)");
+ {
+ char * text = (char *)SvPV_nolen(ST(0));
+#line 48 "KVIrc.xs"
+ if(!g_bExecuteQuiet)
+ g_lWarningList.append(QString(text));
+#line 113 "KVIrc.c"
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(XS_KVIrc_getLocal); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_getLocal)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: KVIrc::getLocal(varname)");
+ {
+ char * varname = (char *)SvPV_nolen(ST(0));
+ char * RETVAL;
+ dXSTARG;
+#line 55 "KVIrc.xs"
+ QString tmp;
+ KviStr hack;
+ if(g_pCurrentKvsContext)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->localVariables()->find(varname);
+ if(pVar)
+ {
+ pVar->asString(tmp);
+ hack = tmp;
+ RETVAL = hack.ptr();
+ } else RETVAL = "";
+ }
+#line 141 "KVIrc.c"
+ sv_setpv(TARG, RETVAL); XSprePUSH; PUSHTARG;
+ }
+ XSRETURN(1);
+}
+
+XS(XS_KVIrc_setLocal); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_setLocal)
+{
+ dXSARGS;
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: KVIrc::setLocal(varname, value)");
+ {
+ char * varname = (char *)SvPV_nolen(ST(0));
+ char * value = (char *)SvPV_nolen(ST(1));
+#line 74 "KVIrc.xs"
+ if(g_pCurrentKvsContext)
+ {
+ if(value && *value)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->localVariables()->get(varname);
+ pVar->setString(value);
+ } else {
+ g_pCurrentKvsContext->localVariables()->unset(varname);
+ }
+ }
+#line 167 "KVIrc.c"
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(XS_KVIrc_getGlobal); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_getGlobal)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: KVIrc::getGlobal(varname)");
+ {
+ char * varname = (char *)SvPV_nolen(ST(0));
+ char * RETVAL;
+ dXSTARG;
+#line 88 "KVIrc.xs"
+ QString tmp;
+ KviStr hack;
+ if(g_pCurrentKvsContext)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->globalVariables()->find(varname);
+ if(pVar)
+ {
+ pVar->asString(tmp);
+ hack = tmp;
+ RETVAL = hack.ptr();
+ } else RETVAL = "";
+ }
+#line 195 "KVIrc.c"
+ sv_setpv(TARG, RETVAL); XSprePUSH; PUSHTARG;
+ }
+ XSRETURN(1);
+}
+
+XS(XS_KVIrc_setGlobal); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_setGlobal)
+{
+ dXSARGS;
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: KVIrc::setGlobal(varname, value)");
+ {
+ char * varname = (char *)SvPV_nolen(ST(0));
+ char * value = (char *)SvPV_nolen(ST(1));
+#line 107 "KVIrc.xs"
+ if(g_pCurrentKvsContext)
+ {
+ if(value && *value)
+ {
+ KviKvsVariant * pVar = g_pCurrentKvsContext->globalVariables()->get(varname);
+ pVar->setString(value);
+ } else {
+ g_pCurrentKvsContext->localVariables()->unset(varname);
+ }
+ }
+#line 221 "KVIrc.c"
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(XS_KVIrc_eval); /* prototype to pass -Wmissing-prototypes */
+XS(XS_KVIrc_eval)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: KVIrc::eval(code)");
+ {
+ char * code = (char *)SvPV_nolen(ST(0));
+ char * RETVAL;
+ dXSTARG;
+#line 122 "KVIrc.xs"
+ if(g_pCurrentKvsContext && code)
+ {
+ KviKvsVariant ret;
+ if(KviKvsScript::run(QString::fromUtf8(code),g_pCurrentKvsContext->window(),0,&ret))
+ {
+ QString tmp;
+ ret.asString(tmp);
+ g_szLastReturnValue = tmp;
+ } else {
+ g_szLastReturnValue = "";
+ }
+ RETVAL = g_szLastReturnValue.ptr();
+ } else {
+ RETVAL = "";
+ }
+#line 252 "KVIrc.c"
+ sv_setpv(TARG, RETVAL); XSprePUSH; PUSHTARG;
+ }
+ XSRETURN(1);
+}
+
+#ifdef __cplusplus
+extern "C"
+#endif
+XS(boot_KVIrc); /* prototype to pass -Wmissing-prototypes */
+XS(boot_KVIrc)
+{
+ dXSARGS;
+ char* file = __FILE__;
+
+ newXS("KVIrc::echo", XS_KVIrc_echo, file);
+ newXS("KVIrc::say", XS_KVIrc_say, file);
+ newXS("KVIrc::warning", XS_KVIrc_warning, file);
+ newXS("KVIrc::internalWarning", XS_KVIrc_internalWarning, 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);
+ XSRETURN_YES;
+}
+
generated by cgit v1.2.1 (git 2.18.0) at 2024-12-12 04:51:23 +0000