gplugin/gplugin
Clone
Summary
Browse
Changes
Graph
Added tag v0.33.0 for changeset f04edbdc6e9e
2021-08-03, Gary Kramlich
0a36794339eb
Added tag v0.33.0 for changeset f04edbdc6e9e
/*
* 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"
#include
<gperl.h>
struct
_GPluginPerlLoader
{
GPluginLoader
parent
;
};
G_DEFINE_DYNAMIC_TYPE
(
GPluginPerlLoader
,
gplugin_perl_loader
,
GPLUGIN_TYPE_LOADER
);
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
;
PerlInterpreter
*
old
=
NULL
;
SV
*
err_tmp
;
gint
ret
=
0
;
dSP
;
old
=
my_perl
;
my_perl
=
interpreter
;
PERL_SET_CONTEXT
(
interpreter
);
ENTER
;
SAVETMPS
;
PUSHMARK
(
SP
);
PUTBACK
;
ret
=
call_pv
(
"gplugin_query"
,
G_EVAL
|
G_NOARGS
);
SPAGAIN
;
/* ERRSV is a macro, so we store it instead of calling it multiple times. */
err_tmp
=
ERRSV
;
if
(
SvTRUE
(
err_tmp
))
{
const
gchar
*
errmsg
=
SvPVutf8_nolen
(
err_tmp
);
g_set_error_literal
(
error
,
GPLUGIN_DOMAIN
,
0
,
errmsg
);
}
else
{
if
(
ret
!=
1
)
{
g_set_error_literal
(
error
,
GPLUGIN_DOMAIN
,
0
,
"gplugin_query did not return a GPluginPluginInfo"
);
}
else
{
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
));
}
}
}
PUTBACK
;
FREETMPS
;
LEAVE
;
my_perl
=
old
;
return
info
;
}
/******************************************************************************
* GPluginLoaderInterface API
*****************************************************************************/
static
GSList
*
gplugin_perl_loader_supported_extensions
(
G_GNUC_UNUSED
GPluginLoader
*
l
)
{
return
g_slist_append
(
NULL
,
"pl"
);
}
static
GPluginPlugin
*
gplugin_perl_loader_query
(
GPluginLoader
*
loader
,
const
gchar
*
filename
,
GError
**
error
)
{
GPluginPlugin
*
plugin
=
NULL
;
GPluginPluginInfo
*
info
=
NULL
;
PerlInterpreter
*
interpreter
=
NULL
;
const
gchar
*
args
[]
=
{
""
,
filename
};
gchar
**
argv
=
(
gchar
**
)
args
;
gint
argc
=
2
,
ret
=
0
;
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
);
return
NULL
;
}
ret
=
perl_run
(
interpreter
);
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
);
return
NULL
;
}
info
=
gplugin_perl_loader_call_gplugin_query
(
interpreter
,
error
);
if
(
!
GPLUGIN_IS_PLUGIN_INFO
(
info
))
{
if
(
error
!=
NULL
&&
*
error
==
NULL
)
{
g_set_error_literal
(
error
,
GPLUGIN_DOMAIN
,
0
,
"failed to query"
);
}
return
NULL
;
}
/* clang-format off */
plugin
=
g_object_new
(
GPLUGIN_PERL_TYPE_PLUGIN
,
"interpreter"
,
interpreter
,
"filename"
,
filename
,
"info"
,
info
,
"loader"
,
g_object_ref
(
loader
),
NULL
);
/* clang-format on */
return
plugin
;
}
static
gboolean
gplugin_perl_loader_load
(
G_GNUC_UNUSED
GPluginLoader
*
loader
,
GPluginPlugin
*
plugin
,
GError
**
error
)
{
GPluginPerlPlugin
*
pplugin
=
GPLUGIN_PERL_PLUGIN
(
plugin
);
PerlInterpreter
*
old
=
NULL
;
SV
*
err_tmp
=
NULL
;
gboolean
r
=
FALSE
;
gint
count
=
0
;
dSP
;
old
=
my_perl
;
my_perl
=
gplugin_perl_plugin_get_interpreter
(
pplugin
);
PERL_SET_CONTEXT
(
my_perl
);
ENTER
;
SAVETMPS
;
PUSHMARK
(
SP
);
EXTEND
(
SP
,
1
);
PUSHs
(
sv_2mortal
(
newSVGObject
(
G_OBJECT
(
pplugin
))));
PUTBACK
;
count
=
call_pv
(
"gplugin_load"
,
G_EVAL
|
G_SCALAR
);
SPAGAIN
;
/* ERRSV is a macro, so we store it instead of calling it multiple times. */
err_tmp
=
ERRSV
;
if
(
SvTRUE
(
err_tmp
))
{
const
gchar
*
errmsg
=
SvPVutf8_nolen
(
err_tmp
);
g_set_error_literal
(
error
,
GPLUGIN_DOMAIN
,
0
,
errmsg
);
}
else
{
if
(
count
!=
1
)
{
g_set_error_literal
(
error
,
GPLUGIN_DOMAIN
,
0
,
"gplugin_load did not return a value"
);
}
else
{
if
(
POPi
==
0
)
{
r
=
TRUE
;
}
}
}
PUTBACK
;
FREETMPS
;
LEAVE
;
my_perl
=
old
;
/* this is magic and is keeping this working. Why I don't know, but we're
* debating chucking this loader out the window and I want to create this
* review request so I'm leaving it in for now...
*/
g_message
(
"load returning: %d for %s"
,
r
,
gplugin_plugin_get_filename
(
plugin
));
return
r
;
}
static
gboolean
gplugin_perl_loader_unload
(
G_GNUC_UNUSED
GPluginLoader
*
loader
,
GPluginPlugin
*
plugin
,
GError
**
error
)
{
GPluginPerlPlugin
*
pplugin
=
GPLUGIN_PERL_PLUGIN
(
plugin
);
PerlInterpreter
*
old
=
NULL
;
SV
*
err_tmp
=
NULL
;
gboolean
r
=
FALSE
;
gint
count
=
0
;
dSP
;
old
=
my_perl
;
my_perl
=
gplugin_perl_plugin_get_interpreter
(
pplugin
);
PERL_SET_CONTEXT
(
my_perl
);
ENTER
;
SAVETMPS
;
PUSHMARK
(
SP
);
EXTEND
(
SP
,
1
);
PUSHs
(
sv_2mortal
(
newSVGObject
(
G_OBJECT
(
pplugin
))));
PUTBACK
;
count
=
call_pv
(
"gplugin_unload"
,
G_EVAL
|
G_SCALAR
);
SPAGAIN
;
/* ERRSV is a macro, so we store it instead of calling it multiple times. */
err_tmp
=
ERRSV
;
if
(
SvTRUE
(
err_tmp
))
{
const
gchar
*
errmsg
=
SvPVutf8_nolen
(
err_tmp
);
g_set_error_literal
(
error
,
GPLUGIN_DOMAIN
,
0
,
errmsg
);
}
else
{
if
(
count
!=
1
)
{
g_set_error_literal
(
error
,
GPLUGIN_DOMAIN
,
0
,
"gplugin_unload did not return a value"
);
}
else
{
if
(
POPi
==
0
)
{
r
=
TRUE
;
}
}
}
PUTBACK
;
FREETMPS
;
LEAVE
;
my_perl
=
old
;
return
r
;
}
/******************************************************************************
* GObject Stuff
*****************************************************************************/
static
void
gplugin_perl_loader_init
(
G_GNUC_UNUSED
GPluginPerlLoader
*
loader
)
{
}
static
void
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
();
}
static
void
gplugin_perl_loader_class_finalize
(
G_GNUC_UNUSED
GPluginPerlLoaderClass
*
klass
)
{
/* perl uninitialization */
gplugin_perl_loader_uninit_perl
();
}
/******************************************************************************
* API
*****************************************************************************/
void
gplugin_perl_loader_register
(
GTypeModule
*
module
)
{
gplugin_perl_loader_register_type
(
module
);
}