* Copyright (C) 2011-2020 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 <https://www.gnu.org/licenses/>. #include "gplugin-perl5-loader.h" #include "gplugin-perl5-plugin.h" struct _GPluginPerlLoader { static PerlInterpreter *my_perl = NULL; /****************************************************************************** *****************************************************************************/ extern void boot_DynaLoader(pTHX_ CV *cv); gplugin_perl_loader_xs_init(pTHX) newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__); gplugin_perl_loader_init_perl(void) gchar **argv = (gchar **)args; PERL_SYS_INIT(&argc, &argv); PERL_SET_CONTEXT(my_perl); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; gplugin_perl_loader_uninit_perl(void) PERL_SET_CONTEXT(my_perl); static GPluginPluginInfo * gplugin_perl_loader_call_gplugin_query( PerlInterpreter *interpreter, GPluginPluginInfo *info = NULL; PerlInterpreter *old = NULL; PERL_SET_CONTEXT(interpreter); ret = call_pv("gplugin_query", G_EVAL | G_NOARGS); /* ERRSV is a macro, so we store it instead of calling it multiple times. */ const gchar *errmsg = SvPVutf8_nolen(err_tmp); g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg); "gplugin_query did not return a GPluginPluginInfo"); info = (GPluginPluginInfo *)gperl_get_object(POPs); /* if we did get a real GPluginPluginInfo ref it because the perl * code below will take it out of scope and delete it if its * reference count is zero. if(GPLUGIN_IS_PLUGIN_INFO(info)) { g_object_ref(G_OBJECT(info)); /****************************************************************************** * GPluginLoaderInterface API *****************************************************************************/ gplugin_perl_loader_supported_extensions(G_GNUC_UNUSED GPluginLoader *l) return g_slist_append(NULL, "pl"); gplugin_perl_loader_query( GPluginPlugin *plugin = NULL; GPluginPluginInfo *info = NULL; PerlInterpreter *interpreter = NULL; const gchar *args[] = {"", filename}; gchar **argv = (gchar **)args; interpreter = perl_alloc(); PERL_SET_CONTEXT(interpreter); PL_perl_destruct_level = 1; perl_construct(interpreter); perl_parse(interpreter, gplugin_perl_loader_xs_init, argc, argv, NULL); const gchar *errmsg = "unknown error"; /* ERRSV is a macro so we need to store its returned value so we don't * call it multiple times. errmsg = SvPVutf8_nolen(err_tmp); g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg); perl_destruct(interpreter); ret = perl_run(interpreter); const gchar *errmsg = "unknown error"; /* ERRSV is a macro so we need to store its returned value so we don't * call it multiple times. errmsg = SvPVutf8_nolen(err_tmp); g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg); perl_destruct(interpreter); info = gplugin_perl_loader_call_gplugin_query(interpreter, error); if(!GPLUGIN_IS_PLUGIN_INFO(info)) { /* If the plugin's query method didn't set error, set it to a generic if(error != NULL && *error == NULL) { g_set_error_literal(error, GPLUGIN_DOMAIN, 0, "failed to query"); GPLUGIN_PERL_TYPE_PLUGIN, "interpreter", interpreter, "loader", g_object_ref(loader), gplugin_perl_loader_load( G_GNUC_UNUSED GPluginLoader *loader, GPluginPerlPlugin *pplugin = GPLUGIN_PERL_PLUGIN(plugin); PerlInterpreter *old = NULL; my_perl = gplugin_perl_plugin_get_interpreter(pplugin); PERL_SET_CONTEXT(my_perl); PUSHs(sv_2mortal(newSVGObject(g_object_ref(G_OBJECT(pplugin))))); count = call_pv("gplugin_load", G_EVAL | G_SCALAR); /* ERRSV is a macro, so we store it instead of calling it multiple times. */ const gchar *errmsg = SvPVutf8_nolen(err_tmp); g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg); "gplugin_load did not return a value"); PERL_SET_CONTEXT(my_perl); gplugin_perl_loader_unload( G_GNUC_UNUSED GPluginLoader *loader, GPluginPerlPlugin *pplugin = GPLUGIN_PERL_PLUGIN(plugin); PerlInterpreter *old = NULL; my_perl = gplugin_perl_plugin_get_interpreter(pplugin); PERL_SET_CONTEXT(my_perl); PUSHs(sv_2mortal(newSVGObject(g_object_ref(G_OBJECT(pplugin))))); PUSHs(sv_2mortal(newSViv(shutdown))); count = call_pv("gplugin_unload", G_EVAL | G_SCALAR); /* ERRSV is a macro, so we store it instead of calling it multiple times. */ const gchar *errmsg = SvPVutf8_nolen(err_tmp); g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg); "gplugin_unload did not return a value"); PERL_SET_CONTEXT(my_perl); /****************************************************************************** *****************************************************************************/ gplugin_perl_loader_init(G_GNUC_UNUSED GPluginPerlLoader *loader) gplugin_perl_loader_class_init(GPluginPerlLoaderClass *klass) GPluginLoaderClass *loader_class = GPLUGIN_LOADER_CLASS(klass); loader_class->supported_extensions = gplugin_perl_loader_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(); gplugin_perl_loader_class_finalize(G_GNUC_UNUSED GPluginPerlLoaderClass *klass) /* perl uninitialization */ gplugin_perl_loader_uninit_perl(); /****************************************************************************** *****************************************************************************/ gplugin_perl_loader_register(GTypeModule *module) gplugin_perl_loader_register_type(module); gplugin_perl_loader_new(void) GPLUGIN_PERL_TYPE_LOADER,