Glib
view release on metacpan or search on metacpan
/*
* Copyright (C) 2003-2006, 2010, 2012-2013 by the gtk2-perl team (see the
* file AUTHORS for the full list)
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Library General Public License as published by
* the Free Software Foundation; either version 2.1 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 Library General Public
* License for more details.
*
* You should have received a copy of the GNU Library General Public License
* along with this library; if not, write to the Free Software Foundation,
* Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*
* $Id$
*/
/*
* the POD directives in here will be stripped by xsubpp before compilation,
* and are intended to be extracted by podselect when creating xs api
* reference documentation. pod must NOT appear within C comments, because
* it gets replaced by a comment that says "embedded pod stripped".
*/
=head2 GObject
To deal with the intricate interaction of the different reference-counting
semantics of Perl objects versus GObjects, the bindings create a combined
PerlObject+GObject, with the GObject's pointer in magic attached to the Perl
object, and the Perl object's pointer in the GObject's user data. Thus it's
not really a "wrapper", but we refer to it as one, because "combined Perl
object + GObject" is a cumbersome and confusing mouthful.
GObjects are represented as blessed hash references. The GObject user data
mechanism is not typesafe, and thus is used only for unsigned integer values;
the Perl-level hash is available for any type of user data. The combined
nature of the wrapper means that data stored in the hash will stick around as
long as the object is alive.
Since the C pointer is stored in attached magic, the C pointer is not available
to the Perl developer via the hash object, so there's no need to worry about
breaking it from perl.
Propers go to Marc Lehmann for dreaming most of this up.
=over
=cut
#include "gperl.h"
#include "gperl-private.h" /* for GPERL_SET_CONTEXT and
* _gperl_sv_from_value_internal */
typedef struct _ClassInfo ClassInfo;
typedef struct _SinkFunc SinkFunc;
struct _ClassInfo {
GType gtype;
char * package;
gboolean initialized;
};
struct _SinkFunc {
GType gtype;
GPerlObjectSinkFunc func;
};
static GHashTable * types_by_type = NULL;
static GHashTable * types_by_package = NULL;
/* store outside of the class info maps any options we expect to be sparse;
* this will save us a fair amount of space. */
static GHashTable * nowarn_by_type = NULL;
static GArray * sink_funcs = NULL;
static GQuark wrapper_quark; /* this quark stores the object's wrapper sv */
/* what should be done here */
#define GPERL_THREAD_SAFE !GPERL_DISABLE_THREADSAFE
#if GPERL_THREAD_SAFE
/* keep a list of all gobjects */
static gboolean perl_gobject_tracking = FALSE;
static GHashTable * perl_gobjects = NULL;
G_LOCK_DEFINE_STATIC (perl_gobjects);
#endif
/* thread safety locks for the modifiables above */
G_LOCK_DEFINE_STATIC (types_by_type);
G_LOCK_DEFINE_STATIC (types_by_package);
G_LOCK_DEFINE_STATIC (nowarn_by_type);
G_LOCK_DEFINE_STATIC (sink_funcs);
static MGVTBL gperl_mg_vtbl;
/*
* Attach a C<ptr> to the given C<sv>. It can be retrieved later using
}
} else
croak ("internal problem: gperl_object_type_from_package "
"called before any classes were registered");
return 0; /* not reached */
}
/*
* Manipulate a pointer to indicate that an SV is undead.
* Relies on SV pointers being word-aligned.
*/
#define IS_UNDEAD(x) (PTR2UV(x) & 1)
#define MAKE_UNDEAD(x) INT2PTR(void*, PTR2UV(x) | 1)
#define REVIVE_UNDEAD(x) INT2PTR(void*, PTR2UV(x) & ~1)
/*
* this function is called whenever the gobject gets destroyed. this only
* happens if the perl object is no longer referenced anywhere else, so
* put it to final rest here.
*/
static void
gobject_destroy_wrapper (SV *obj)
{
GPERL_SET_CONTEXT;
/* As of perl 5.16, this function needs to run even during global
* destruction (i.e. when PL_in_clean_objs is true) since we might
* otherwise end up with undead HVs hanging on to garbage. Prior to
* 5.16, this did not matter, but recent versions of perl will find
* these HVs and call DESTROY on them. */
#ifdef NOISY
warn ("gobject_destroy_wrapper (%p)[%d]\n", obj,
SvREFCNT ((SV*)REVIVE_UNDEAD(obj)));
#endif
obj = REVIVE_UNDEAD(obj);
_gperl_remove_mg (obj);
/* we might want to optimize away the call to DESTROY here for non-perl classes. */
SvREFCNT_dec (obj);
}
static void
update_wrapper (GObject *object, gpointer obj)
{
/* printf("update_wrapper [%p] (%p)\n", object, obj); */
g_object_steal_qdata (object, wrapper_quark);
g_object_set_qdata_full (object,
wrapper_quark,
obj,
(GDestroyNotify)gobject_destroy_wrapper);
}
=item SV * gperl_new_object (GObject * object, gboolean own)
Use this function to get the perl part of a GObject. If I<object>
has never been seen by perl before, a new, empty perl object will
be created and added to a private key under I<object>'s qdata. If
I<object> already has a perl part, a new reference to it will be
created. The gobject + perl object together form a combined object that
is properly refcounted, i.e. both parts will stay alive as long as at
least one of them is alive, and only when both perl object and gobject are
no longer referenced will both be freed.
The perl object will be blessed into the package corresponding to the GType
returned by calling G_OBJECT_TYPE() on I<object>; if that class has not
been registered via gperl_register_object(), this function will emit a
warning to that effect (with warn()), and attempt to bless it into the
first known class in the object's ancestry. Since Glib::Object is
already registered, you'll get a Glib::Object if you are lazy, and thus
this function can fail only if I<object> isn't descended from GObject,
in which case it croaks. (In reality, if you pass a non-GObject to this
function, you'll be lucky if you don't get a segfault, as there's not
really a way to trap that.) In practice these warnings can be unavoidable,
so you can use gperl_object_set_no_warn_unreg_subclass() to quell them
on a class-by-class basis.
However, when perl code is calling a GObject constructor (any function
which returns a new GObject), call gperl_new_object() with I<own> set to
%TRUE; this will cause the first matching sink function to be called
on the GObject to claim ownership of that object, so that it will be
destroyed when the perl object goes out of scope. The default sink func
is g_object_unref(); other types should supply the proper function;
e.g., GtkObject should use gtk_object_sink() here.
Returns the blessed perl object, or #&PL_sv_undef if object was #NULL.
=cut
SV *
gperl_new_object (GObject * object,
gboolean own)
{
SV *obj;
SV *sv;
/* take the easy way out if we can */
if (!object) {
#ifdef NOISY
warn ("gperl_new_object (NULL) => undef\n");
#endif
return &PL_sv_undef;
}
if (!G_IS_OBJECT (object))
croak ("object %p is not really a GObject", object);
/* fetch existing wrapper_data */
obj = (SV *)g_object_get_qdata (object, wrapper_quark);
if (!obj) {
/* create the perl object */
GType gtype = G_OBJECT_TYPE (object);
HV *stash = gperl_object_stash_from_type (gtype);
/* We should only get NULL for the stash here if gtype is
* neither a GObject nor GInterface. We filtered out all
* non-GObject types a few lines back. */
g_assert (stash != NULL);
/*
/* helper for g_object_[gs]et_parameter */
static void
init_property_value (GObject * object,
const char * name,
GValue * value)
{
GParamSpec * pspec;
pspec = g_object_class_find_property (G_OBJECT_GET_CLASS (object),
name);
if (!pspec) {
const char * classname =
gperl_object_package_from_type (G_OBJECT_TYPE (object));
if (!classname)
classname = G_OBJECT_TYPE_NAME (object);
croak ("type %s does not support property '%s'",
classname, name);
}
g_value_init (value, G_PARAM_SPEC_VALUE_TYPE (pspec));
}
=item typedef GObject GObject_noinc
=item typedef GObject GObject_ornull
=item newSVGObject(obj)
=item newSVGObject_noinc(obj)
=item SvGObject(sv)
=item SvGObject_ornull(sv)
=back
=cut
/*
* $sv = $object->{name}
*
* if the key doesn't exist with name, convert - to _ and try again.
* that is, support both "funny-name" and "funny_name".
*
* if create is true, autovivify the key (and always return a value).
* if create is false, returns NULL is there is no such key.
*/
SV *
_gperl_fetch_wrapper_key (GObject * object,
const char * name,
gboolean create)
{
SV ** svp;
SV * svname;
HV * wrapper_hash;
wrapper_hash = g_object_get_qdata (object, wrapper_quark);
/* we don't care whether the wrapper is alive or undead. forcibly
* remove the undead bit, or the pointer will be unusable. */
wrapper_hash = REVIVE_UNDEAD (wrapper_hash);
svname = newSVpv (name, strlen (name));
svp = hv_fetch (wrapper_hash, SvPV_nolen (svname), SvCUR (svname),
FALSE); /* never create on the first try; prefer
* prefer to create the second version. */
if (!svp) {
/* the key doesn't exist with that name. do s/-/_/g and
* try again. */
register char * c;
for (c = SvPV_nolen (svname); c <= SvEND (svname) ; c++)
if (*c == '-')
*c = '_';
svp = hv_fetch (wrapper_hash,
SvPV_nolen (svname), SvCUR (svname),
create);
}
SvREFCNT_dec (svname);
return (svp ? *svp : NULL);
}
#if GPERL_THREAD_SAFE
static void
_inc_ref_and_count (GObject * key, gint value, gpointer user_data)
{
PERL_UNUSED_VAR (user_data);
g_object_ref (key);
value += 1;
g_hash_table_replace (perl_gobjects, key, GINT_TO_POINTER (value));
}
#endif
MODULE = Glib::Object PACKAGE = Glib::Object PREFIX = g_object_
#if GPERL_THREAD_SAFE
=for apidoc __hide__
Users shouldn't know this exists.
This is part of the machinery to support object tracking in a threaded
environment. When perl spawns a new interpreter thread, it invokes
CLONE on all packages -- NOT on objects. This is our only hook into
that process.
=cut
void
CLONE (gchar * class)
CODE:
/* !perl_gobjects can happen when no object has been created yet. */
if (perl_gobject_tracking && perl_gobjects &&
strcmp (class, "Glib::Object") == 0)
{
G_LOCK (perl_gobjects);
/*g_printerr ("we're in clone: %s\n", class);*/
g_hash_table_foreach (perl_gobjects,
(GHFunc)_inc_ref_and_count, NULL);
The type that owns the property
=item descr
The description of the property
=item flags
The Glib::ParamFlags of the property
=back
=cut
=for apidoc Glib::Object::find_property
=for signature pspec or undef = $object_or_class_name->find_property ($name)
=for arg name (string)
=for arg ... (__hide__)
Find the definition of object property I<$name> for I<$object_or_class_name>.
Return C<undef> if no such property. For
the returned data see L<Glib::Object::list_properties>.
=cut
void
g_object_find_property (object_or_class_name, ...)
SV * object_or_class_name
ALIAS:
Glib::Object::list_properties = 1
PREINIT:
GType type = G_TYPE_INVALID;
gchar *name = NULL;
PPCODE:
if (gperl_sv_is_ref (object_or_class_name)) {
GObject * object = SvGObject (object_or_class_name);
if (!object)
croak ("wha? NULL object in list_properties");
type = G_OBJECT_TYPE (object);
} else {
type = gperl_object_type_from_package
(SvPV_nolen (object_or_class_name));
if (!type)
croak ("package %s is not registered with GPerl",
SvPV_nolen (object_or_class_name));
}
if (ix == 0 && items == 2) {
name = SvGChar (ST (1));
#ifdef NOISY
warn ("Glib::Object::find_property ('%s', '%s')\n",
g_type_name (type),
name);
#endif
}
else if (ix == 0 && items != 2)
croak ("Usage: Glib::Object::find_property (class, name)");
else if (ix == 1 && items != 1)
croak ("Usage: Glib::Object::list_properties (class)");
if (G_TYPE_IS_OBJECT (type))
{
/* classes registered by perl are kept alive by the bindings.
* those coming straight from C are not. if we had an actual
* object, the class will be alive, but if we just had a
* package, the class may not exist yet. thus, we'll have to
* do an honest ref here, rather than a peek.
*/
GObjectClass *object_class = g_type_class_ref (type);
if (ix == 0) {
GParamSpec *pspec;
pspec = g_object_class_find_property (object_class, name);
if (pspec)
XPUSHs (sv_2mortal (newSVGParamSpec (pspec)));
else
XPUSHs (newSVsv (&PL_sv_undef));
}
else if (ix == 1) {
GParamSpec **props;
guint n_props, i;
props = g_object_class_list_properties (object_class, &n_props);
#ifdef NOISY
warn ("list_properties: %d properties\n", n_props);
#endif
if (n_props) {
EXTEND (SP, (int) n_props);
for (i = 0; i < n_props; i++)
PUSHs (sv_2mortal (newSVGParamSpec (props[i])));
}
g_free (props); /* must free even when n_props==0 */
}
g_type_class_unref (object_class);
}
#if GLIB_CHECK_VERSION(2,4,0)
else if (G_TYPE_IS_INTERFACE (type))
{
gpointer iface = g_type_default_interface_ref (type);
if (ix == 0) {
GParamSpec *pspec;
pspec = g_object_interface_find_property (iface, name);
if (pspec)
XPUSHs (sv_2mortal (newSVGParamSpec (pspec)));
else
XPUSHs (newSVsv (&PL_sv_undef));
}
else if (ix == 1) {
GParamSpec **props;
guint n_props, i;
props = g_object_interface_list_properties (iface, &n_props);
#ifdef NOISY
warn ("list_properties: %d properties\n", n_props);
#endif
if (n_props) {
EXTEND (SP, (int) n_props);
for (i = 0; i < n_props; i++)
( run in 0.872 second using v1.01-cache-2.11-cpan-39bf76dae61 )