qulogic/gplugin

More work towards getting perl to work...
feature/perl-again
2019-07-18, Gary Kramlich
431688d567af
Parents 1a6908462ac7
Children 982bd642216e
More work towards getting perl to work...
9 files changed, 362 insertions(+), 56 deletions(-)
  • +147 -36
    perl/gplugin-perl-loader.c
  • +15 -9
    perl/meson.build
  • +13 -0
    perl/tests/meson.build
  • +13 -11
    perl/tests/plugins/basic.pl
  • +36 -0
    perl/tests/plugins/dependent.pl
  • +37 -0
    perl/tests/plugins/load-exception.pl
  • +35 -0
    perl/tests/plugins/load-failed.pl
  • +35 -0
    perl/tests/plugins/unload-failed.pl
  • +31 -0
    perl/tests/test-perl-loader.c
    • --- a/perl/gplugin-perl-loader.c Thu Jul 18 01:13:19 2019 +0000
    +++ b/perl/gplugin-perl-loader.c Thu Jul 18 20:34:36 2019 -0500
    @@ -28,10 +28,106 @@
    G_DEFINE_DYNAMIC_TYPE(GPluginPerlLoader, gplugin_perl_loader, GPLUGIN_TYPE_LOADER);
    -/* I can't believe I have to use this variable name... */
    static PerlInterpreter *my_perl = NULL;
    /******************************************************************************
    + * Perl Stuff
    + *****************************************************************************/
    +extern void boot_DynaLoader(pTHX_ CV* cv);
    +
    +static void
    +gplugin_perl_loader_xs_init(pTHX) {
    + dXSUB_SYS;
    +
    + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
    +}
    +
    +static void
    +gplugin_perl_loader_init_perl(void) {
    + gchar *args[] = { "", };
    + gchar **argv = (gchar **)args;
    + gint argc = 1;
    +
    + PERL_SYS_INIT(&argc, &argv);
    +
    + my_perl = perl_alloc();
    + PERL_SET_CONTEXT(my_perl);
    + PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
    + perl_construct(my_perl);
    +}
    +
    +static void
    +gplugin_perl_loader_uninit_perl(void) {
    + PERL_SET_CONTEXT(my_perl);
    + perl_destruct(my_perl);
    + perl_free(my_perl);
    + PERL_SYS_TERM();
    +}
    +
    +static GPluginPluginInfo *
    +gplugin_perl_loader_call_gplugin_query(PerlInterpreter *interpreter, GError **error) {
    + GPluginPluginInfo *info = NULL;
    + SV *sv_info = NULL;
    + gint ret = 0;
    +
    + dSP;
    + PERL_SET_CONTEXT(interpreter);
    +
    + ENTER;
    + SAVETMPS;
    +
    + PUSHMARK(SP);
    + PUTBACK;
    +
    + ret = call_pv("gplugin_query", G_EVAL | G_NOARGS);
    +
    + g_warning("ret: %d", ret);
    +
    + SPAGAIN;
    +
    + if(ret != 1) {
    + g_set_error(error, GPLUGIN_DOMAIN, 0, "gplugin_query did not return a GPluginPluginInfo");
    +
    + return NULL;
    + }
    +
    + if(SvTRUE(ERRSV)) {
    + const gchar *errmsg = "unknown error";
    +
    + if(SvTRUE(ERRSV)) {
    + errmsg = SvPVutf8_nolen(ERRSV);
    + }
    +
    + g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg);
    +
    + return NULL;
    + }
    +
    + sv_info = POPs;
    +
    + g_message("sv_info: %p", sv_info);
    +
    + FREETMPS;
    + LEAVE;
    +
    + return info;
    +}
    +
    +static gboolean
    +gplugin_perl_loader_call_gplugin_load(PerlInterpreter *interpreter) {
    + dSP;
    + PERL_SET_CONTEXT(interpreter);
    + SPAGAIN;
    + ENTER;
    + SAVETMPS;
    + PUSHMARK(SP);
    +
    + call_pv("gplugin_load", G_EVAL | G_SCALAR);
    +
    + return TRUE;
    +}
    +
    +/******************************************************************************
    * GPluginLoaderInterface API
    *****************************************************************************/
    static GSList *
    @@ -41,63 +137,78 @@
    static GPluginPlugin *
    gplugin_perl_loader_query(GPluginLoader *loader,
    - const gchar *filename,
    - GError **error)
    + const gchar *filename,
    + GError **error)
    {
    + GPluginPluginInfo *info = NULL;
    + PerlInterpreter *interpreter = NULL;
    const gchar *args[] = { "", filename };
    gchar **argv = (gchar **)args;
    - gint argc = 2;
    + gint argc = 2, ret = 0;
    +
    + g_message("querying %s", filename);
    +
    + interpreter = perl_alloc();
    + PERL_SET_CONTEXT(interpreter);
    + PL_perl_destruct_level = 1;
    + perl_construct(interpreter);
    +
    + ret = perl_parse(interpreter, gplugin_perl_loader_xs_init, argc, argv, NULL);
    + if(ret != 0) {
    + const gchar *errmsg = "unknown error";
    +
    + if(SvTRUE(ERRSV)) {
    + errmsg = SvPVutf8_nolen(ERRSV);
    + }
    +
    + g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg);
    +
    + perl_destruct(interpreter);
    + perl_free(interpreter);
    - perl_parse(my_perl, NULL, argc, argv, NULL);
    + return NULL;
    + }
    +
    + ret = perl_run(interpreter);
    + if(ret != 0) {
    + const gchar *errmsg = "unknown error";
    +
    + if(SvTRUE(ERRSV)) {
    + errmsg = SvPVutf8_nolen(ERRSV);
    + }
    - call_argv("gplugin_plugin_query", G_DISCARD | G_NOARGS, argv);
    + g_set_error_literal(error, GPLUGIN_DOMAIN, 0, errmsg);
    +
    + perl_destruct(interpreter);
    + perl_free(interpreter);
    +
    + return NULL;
    + }
    +
    + info = gplugin_perl_loader_call_gplugin_query(interpreter, error);
    +
    + g_message("info: %p", info);
    return NULL;
    }
    static gboolean
    gplugin_perl_loader_load(GPluginLoader *loader,
    - GPluginPlugin *plugin,
    - GError **error)
    + GPluginPlugin *plugin,
    + GError **error)
    {
    return FALSE;
    }
    static gboolean
    gplugin_perl_loader_unload(GPluginLoader *loader,
    - GPluginPlugin *plugin,
    - GError **error)
    + GPluginPlugin *plugin,
    + GError **error)
    {
    return FALSE;
    }
    /******************************************************************************
    - * Perl Stuff
    - *****************************************************************************/
    -static void
    -gplugin_perl_loader_init_perl(void) {
    - gchar *args[] = { "", };
    - 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);
    -}
    -
    -static void
    -gplugin_perl_loader_uninit_perl(void) {
    - PERL_SYS_TERM();
    -
    - perl_destruct(my_perl);
    - perl_free(my_perl);
    - my_perl = NULL;
    -}
    -
    -/******************************************************************************
    * GObject Stuff
    *****************************************************************************/
    static void
    --- a/perl/meson.build Thu Jul 18 01:13:19 2019 +0000
    +++ b/perl/meson.build Thu Jul 18 20:34:36 2019 -0500
    @@ -14,24 +14,30 @@
    'gplugin-perl-plugin.h',
    ]
    + # make sure we have the perl executable, we need it to figrue out the
    + # build arguments.
    PERL = find_program('perl')
    - PERL_CFLAGS = run_command(PERL, '-MExtUtils::Embed', '-e', 'ccopts').stdout()
    - PERL_LDFLAGS = run_command(PERL, '-MExtUtils::Embed', '-e', 'ldopts').stdout()
    - message('PERL_CFLAGS ' + PERL_CFLAGS)
    - message('PERL_LDFLAGS ' + PERL_LDFLAGS)
    + # make sure we have the gobject introspection perl module.
    + run_command(
    + PERL,
    + '-e use Glib::Object::Introspection;',
    + check : true,
    + )
    - PERL_CFLAGS = PERL_CFLAGS.split()
    - PERL_LDFLAGS = PERL_LDFLAGS.split()
    + perl_dep = declare_dependency(
    + compile_args : run_command(PERL, '-MExtUtils::Embed', '-e', 'ccopts', check : true).stdout().split(),
    + link_args : run_command(PERL, '-MExtUtils::Embed', '-e', 'ldopts', check : true).stdout().split(),
    + )
    shared_library('gplugin-perl',
    GPLUGIN_PERL_SOURCES,
    GPLUGIN_PERL_HEADERS,
    - c_args : PERL_CFLAGS,
    - link_args : PERL_LDFLAGS,
    name_prefix : '',
    - dependencies : [gplugin_dep],
    + dependencies : [gplugin_dep, perl_dep],
    install : true,
    install_dir : join_paths(get_option('libdir'), 'gplugin')
    )
    endif # perl
    +
    +subdir('tests')
    --- /dev/null Thu Jan 01 00:00:00 1970 +0000
    +++ b/perl/tests/meson.build Thu Jul 18 20:34:36 2019 -0500
    @@ -0,0 +1,13 @@
    +if get_option('perl')
    +
    +e = executable('test-perl-loader', 'test-perl-loader.c',
    + c_args : [
    + '-DPERL_LOADER_DIR="@0@/perl"'.format(meson.build_root()),
    + '-DPERL_PLUGIN_DIR="@0@/plugins"'.format(
    + meson.current_source_dir()),
    + ],
    + link_with : gplugin_loader_tests,
    + dependencies : [GLIB, GOBJECT, gplugin_dep, perl_dep])
    +test('Perl Loader', e)
    +
    +endif # perl
    --- a/perl/tests/plugins/basic.pl Thu Jul 18 01:13:19 2019 +0000
    +++ b/perl/tests/plugins/basic.pl Thu Jul 18 20:34:36 2019 -0500
    @@ -1,5 +1,4 @@
    -# vi:et:ts=4 sw=4 sts=4
    -# Copyright (C) 2011-2014 Gary Kramlich <grim@reaperworld.com>
    +# Copyright (C) 2011-2019 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
    @@ -20,9 +19,9 @@
    Glib::Object::Introspection->setup(basename => "GPlugin", version => "0.0", package=> "GPlugin");
    -sub gplugin_plugin_query() {
    +sub gplugin_query() {
    return GPlugin::PluginInfo->new(
    - id => "gplugin-perl/basic-plugin",
    + id => "gplugin/perl-basic-plugin",
    abi_version => 0x01000001,
    name => "basic plugin",
    authors => ("Gary Kramlich <grim\@reaperworld.com>"),
    @@ -35,15 +34,18 @@
    );
    }
    -sub gplugin_plugin_load() {
    - my $plugin = shift;
    +sub gplugin_load() {
    + return 0;
    +}
    +sub gplugin_unload() {
    return 0;
    }
    -sub gplugin_plugin_unload() {
    - my $plugin = shift;
    -
    - return 0;
    +my $p = gplugin_query;
    +print "p: $p\n";
    +my $d = &{gplugin_query};
    +print "d: $d\n";
    +foreach my $key (keys %{$p}) {
    + print "key: $key\n";
    }
    -
    --- /dev/null Thu Jan 01 00:00:00 1970 +0000
    +++ b/perl/tests/plugins/dependent.pl Thu Jul 18 20:34:36 2019 -0500
    @@ -0,0 +1,36 @@
    +# Copyright (C) 2011-2019 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/>.
    +
    +use strict;
    +
    +use Glib::Object::Introspection;
    +
    +Glib::Object::Introspection->setup(basename => "GPlugin", version => "0.0", package=> "GPlugin");
    +
    +sub gplugin_query() {
    + return GPlugin::PluginInfo->new(
    + id => "gplugin/perl-dependent-plugin",
    + dependencies => ['dependency1', 'dependenc2'],
    + );
    +}
    +
    +sub gplugin_load() {
    + return 1;
    +}
    +
    +sub gplugin_unload() {
    + return 1;
    +}
    +
    --- /dev/null Thu Jan 01 00:00:00 1970 +0000
    +++ b/perl/tests/plugins/load-exception.pl Thu Jul 18 20:34:36 2019 -0500
    @@ -0,0 +1,37 @@
    +# Copyright (C) 2011-2019 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/>.
    +
    +use strict;
    +
    +use Glib::Object::Introspection;
    +
    +Glib::Object::Introspection->setup(basename => "GPlugin", version => "0.0", package=> "GPlugin");
    +
    +sub gplugin_query() {
    + return GPlugin::PluginInfo->new(
    + id => "gplugin/perl-load-exception",
    + );
    +}
    +
    +sub gplugin_load() {
    + die("you be dead");
    +
    + return 0;
    +}
    +
    +sub gplugin_unload() {
    + return 0;
    +}
    +
    --- /dev/null Thu Jan 01 00:00:00 1970 +0000
    +++ b/perl/tests/plugins/load-failed.pl Thu Jul 18 20:34:36 2019 -0500
    @@ -0,0 +1,35 @@
    +# Copyright (C) 2011-2019 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/>.
    +
    +use strict;
    +
    +use Glib::Object::Introspection;
    +
    +Glib::Object::Introspection->setup(basename => "GPlugin", version => "0.0", package=> "GPlugin");
    +
    +sub gplugin_query() {
    + return GPlugin::PluginInfo->new(
    + id => "gplugin/perl-load-failed",
    + );
    +}
    +
    +sub gplugin_load() {
    + return 1;
    +}
    +
    +sub gplugin_unload() {
    + return 0;
    +}
    +
    --- /dev/null Thu Jan 01 00:00:00 1970 +0000
    +++ b/perl/tests/plugins/unload-failed.pl Thu Jul 18 20:34:36 2019 -0500
    @@ -0,0 +1,35 @@
    +# Copyright (C) 2011-2019 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/>.
    +
    +use strict;
    +
    +use Glib::Object::Introspection;
    +
    +Glib::Object::Introspection->setup(basename => "GPlugin", version => "0.0", package=> "GPlugin");
    +
    +sub gplugin_query() {
    + return GPlugin::PluginInfo->new(
    + id => "gplugin/perl-unload-failed",
    + );
    +}
    +
    +sub gplugin_load() {
    + return 0;
    +}
    +
    +sub gplugin_unload() {
    + return 1;
    +}
    +
    --- /dev/null Thu Jan 01 00:00:00 1970 +0000
    +++ b/perl/tests/test-perl-loader.c Thu Jul 18 20:34:36 2019 -0500
    @@ -0,0 +1,31 @@
    +/*
    + * Copyright (C) 2011-2019 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 <glib.h>
    +#include <gplugin.h>
    +
    +#include <gplugin/gplugin-loader-tests.h>
    +
    +gint
    +main(gint argc, gchar **argv) {
    + g_test_init(&argc, &argv, NULL);
    +
    + gplugin_loader_tests_main(PERL_LOADER_DIR, PERL_PLUGIN_DIR, "pl");
    +
    + return g_test_run();
    +}
    +