qulogic/gplugin
Clone
Summary
Browse
Changes
Graph
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
;
}