qulogic/gplugin

this appears to maybe be working.. ish?
feature/perl-loader
2015-10-12, Gary Kramlich
7655920e36f5
this appears to maybe be working.. ish?
/*
* Copyright (C) 2011-2014 Gary Kramlich <grim@reaperworld.com>
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2 of the License, or (at your option) any later version.
*
* This library 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
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, see <http://www.gnu.org/licenses/>.
*/
#include "gplugin-perl-loader.h"
#include "gplugin-perl-defs.h"
#include <EXTERN.h>
#include <perl.h>
/* perl define's _() to something completely different that we don't use. So
* we undef it so that we can use it for gettext.
*/
#undef _
#include <glib/gi18n.h>
/******************************************************************************
* Globals
*****************************************************************************/
static GObjectClass *parent_class = NULL;
static volatile GType type_real = 0;
/* I can't believe I have to use this variable name... */
static PerlInterpreter *my_perl = NULL;
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
/******************************************************************************
* Helpers
*****************************************************************************/
EXTERN_C void
gplugin_perl_loader_xsinit(pTHX) {
gchar *file = __FILE__;
dXSUB_SYS;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}
static GPluginPluginInfo *
gplugin_perl_query(PerlInterpreter *interp) {
const gchar *sub = "gplugin_query";
SV *sinfo = NULL;
dSP;
PERL_SET_CONTEXT(interp);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
PUTBACK;
call_pv(sub, G_EVAL | G_SCALAR);
SPAGAIN;
sinfo = POPs;
PUTBACK;
FREETMPS;
LEAVE;
g_message("sinfo: %p", sinfo);
return sinfo;
}
/******************************************************************************
* GPluginLoaderInterface API
*****************************************************************************/
static GSList *
gplugin_perl_loader_class_supported_extensions(GPLUGIN_UNUSED const GPluginLoaderClass *klass) {
return g_slist_append(NULL, "pl");
}
static GPluginPlugin *
gplugin_perl_loader_query(GPLUGIN_UNUSED GPluginLoader *loader,
const gchar *filename,
GPLUGIN_UNUSED GError **error)
{
GPluginPluginInfo *info = NULL;
PerlInterpreter *interp = NULL;
const gchar *args[] = { "", "-e", "0", "-w", filename};
gchar **argv = (gchar **)args;
gint argc = 5, ret = 0;
g_message("filename: %s", filename);
PERL_SET_CONTEXT(interp);
interp = perl_alloc();
if(interp == NULL) {
if(error) {
*error = g_error_new(GPLUGIN_DOMAIN, 0, "failed to create a perl interperter");
}
return NULL;
}
perl_construct(interp);
PL_perl_destruct_level = 1; /* perl_construct resets this to 0 */
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
ret = perl_parse(interp, gplugin_perl_loader_xsinit, argc, argv, NULL);
g_message("ret: %d", ret);
if(ret != 0) {
const gchar *msg = "unknown";
if(SvTRUE(ERRSV)) {
g_message("got the warning");
msg = SvPVutf8_nolen(ERRSV);
} else {
g_message("no warning");
}
if(error) {
*error = g_error_new(GPLUGIN_DOMAIN, 0,
"failed to parse %s : %s", filename, msg);
}
perl_destruct(interp);
perl_free(interp);
return NULL;
}
//eval_pv(gplugin_perl_definitions, TRUE);
ret = perl_run(interp);
g_message("ret: %d", ret);
info = gplugin_perl_query(interp);
g_message("info: %p", info);
return NULL;
}
static gboolean
gplugin_perl_loader_load(GPLUGIN_UNUSED GPluginLoader *loader,
GPLUGIN_UNUSED GPluginPlugin *plugin,
GPLUGIN_UNUSED GError **error)
{
return FALSE;
}
static gboolean
gplugin_perl_loader_unload(GPLUGIN_UNUSED GPluginLoader *loader,
GPLUGIN_UNUSED GPluginPlugin *plugin,
GPLUGIN_UNUSED GError **error)
{
return FALSE;
}
/******************************************************************************
* Perl Stuff
*****************************************************************************/
static void
gplugin_perl_loader_init_perl(void) {
gchar *args[] = { "", "-e", "0", "-w", NULL};
gchar **argv = (gchar **)args;
gint argc = 1;
PERL_SYS_INIT(&argc, &argv);
my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
PL_perl_destruct_level = 1;
perl_construct(my_perl);
perl_parse(my_perl, gplugin_perl_loader_xsinit, 4, args, NULL);
perl_run(my_perl);
}
static void
gplugin_perl_loader_uninit_perl(void) {
PERL_SYS_TERM();
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
/******************************************************************************
* Object Stuff
*****************************************************************************/
static void
gplugin_perl_loader_class_init(GPluginPerlLoaderClass *klass) {
GPluginLoaderClass *loader_class = GPLUGIN_LOADER_CLASS(klass);
parent_class = g_type_class_peek_parent(klass);
loader_class->supported_extensions =
gplugin_perl_loader_class_supported_extensions;
loader_class->query = gplugin_perl_loader_query;
loader_class->load = gplugin_perl_loader_load;
loader_class->unload = gplugin_perl_loader_unload;
/* perl initialization */
gplugin_perl_loader_init_perl();
}
static void
gplugin_perl_loader_class_finalize(GPLUGIN_UNUSED GPluginPerlLoaderClass *klass,
GPLUGIN_UNUSED gpointer class_data)
{
/* perl uninitialization */
gplugin_perl_loader_uninit_perl();
}
/******************************************************************************
* API
*****************************************************************************/
void
gplugin_perl_loader_register(GPluginNativePlugin *plugin) {
if(g_once_init_enter(&type_real)) {
GType type = 0;
static const GTypeInfo info = {
.class_size = sizeof(GPluginPerlLoaderClass),
.class_init = (GClassInitFunc)gplugin_perl_loader_class_init,
.class_finalize = (GClassFinalizeFunc)gplugin_perl_loader_class_finalize,
.instance_size = sizeof(GPluginPerlLoader),
};
type = gplugin_native_plugin_register_type(plugin,
GPLUGIN_TYPE_LOADER,
"GPluginPerlLoader",
&info,
0);
g_once_init_leave(&type_real, type);
}
}
GType
gplugin_perl_loader_get_type(void) {
if(G_UNLIKELY(type_real == 0)) {
g_warning("gplugin_perl_loader_get_type was called before "
"the type was registered!\n");
}
return type_real;
}