/*
* Copyright (c) 2003-2005 by the gtk2-perl team (see the file AUTHORS)
*
* 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., 59 Temple Place - Suite 330,
* Boston, MA 02111-1307 USA.
*
* $Id$
*/
#include "gtk2perl.h"
/* #define NOISY */
#ifdef NOISY
static void
destroy_notify (GtkObject * object)
{
g_printerr ("destroy signal on %s(%p)[%d]\n",
G_OBJECT_TYPE_NAME (object),
object,
G_OBJECT (object)->ref_count);
}
static void
weak_ref (gpointer data, GObject * object)
{
g_printerr ("weak ref on %s(%p)[%d]\n",
G_OBJECT_TYPE_NAME (object),
object,
G_OBJECT (object)->ref_count);
}
#endif
/*
* see commentary in gtk2perl.h
*/
SV *
gtk2perl_new_gtkobject (GtkObject * object)
{
#ifdef NOISY
if (object) {
warn ("gtk2perl_new_gtkobject (%s(%p)[%d])\n",
G_OBJECT_TYPE_NAME (object),
object,
G_OBJECT (object)->ref_count);
g_signal_connect (object, "destroy", G_CALLBACK (destroy_notify), NULL);
g_object_weak_ref (G_OBJECT (object), weak_ref, NULL);
} else {
warn ("gtk2perl_new_gtkobject (NULL)\n");
}
#endif
/* always sink the object. if it's not floating, then nothing
* happens and we get a ref. if it is floating, then the
* floating ref gets removed and we're back to 1. */
return gperl_new_object (G_OBJECT (object), TRUE);
}
#ifdef NOISY
static void
gtk2perl_object_sink (GObject * object)
{
warn ("gtk2perl_object_sink (%s(%p)[%d]) %s\n",
G_OBJECT_TYPE_NAME (object),
object,
object->ref_count,
GTK_OBJECT_FLOATING (object) ? "floating" : "");
gtk_object_sink ((GtkObject*)object);
}
#else
# define gtk2perl_object_sink ((GPerlObjectSinkFunc)gtk_object_sink)
#endif
MODULE = Gtk2::Object PACKAGE = Gtk2::Object PREFIX = gtk_object_
BOOT:
/* GtkObject uses a different method of ownership than GObject */
gperl_register_sink_func (GTK_TYPE_OBJECT, gtk2perl_object_sink);
## void gtk_object_sink (GtkObject *object);
## we don't need this to be exported to perl, it's automagical
=for apidoc
This is an explicit destroy --- NOT the auto destroy; Gtk2::Object
inherits that from Glib::Object!
=cut
void
gtk_object_destroy (object)
GtkObject * object
## the rest of the stuff from gtkobject.h is either private, or
## deprecated in favor of corresponding GObject methods.
## however, we need one more for various purposes...
=for apidoc
=for arg object_class package name of object to create
=for arg ... of property-name => value pairs
Create a new object of type I<$object_class>, with some optional initial
property values. You may see this used in some code as Gtk2::Widget->new,
e.g.
$window = Gtk2::Widget->new ('Gtk2::Window',
title => 'something cool',
allow_grow => TRUE);
This is really just a convenience function that wraps Glib::Object->new.
=cut
GtkObject *
new (class, object_class, ...)
const char * object_class
PREINIT:
int i;
int n_params = 0;
GParameter * params = NULL;
GType object_type;
CODE:
object_type = gperl_object_type_from_package (object_class);
if (!object_type)
croak ("%s is not registered with gperl as an object type",
object_class);
if (G_TYPE_IS_ABSTRACT (object_type))
croak ("cannot create instance of abstract (non-instantiatable)"
" type `%s'", g_type_name (object_type));
if (items > 2) {
GObjectClass * class;
if (NULL == (class = g_type_class_ref (object_type)))
croak ("could not get a reference to type class");
n_params = (items - 2) / 2;
if (n_params)
params = gperl_alloc_temp (sizeof (GParameter)
* n_params);
for (i = 0 ; i < n_params ; i++) {
const char * key = SvPV_nolen (ST (2+i*2+0));
GParamSpec * pspec;
pspec = g_object_class_find_property (class, key);
if (!pspec) {
/* crap. unwind to cleanup. */
while (--i >= 0)
g_value_unset (¶ms[i].value);
croak ("type %s does not support property '%s', skipping",
object_class, key);
}
g_value_init (¶ms[i].value,
G_PARAM_SPEC_VALUE_TYPE (pspec));
/* gperl_value_from_sv either succeeds or croaks. */
gperl_value_from_sv (¶ms[i].value, ST (2+i*2+1));
params[i].name = key; /* will be valid until this
* xsub is finished */
}
g_type_class_unref (class);
}
RETVAL = g_object_newv (object_type, n_params, params);
for (i = 0 ; i < n_params ; i++)
g_value_unset (¶ms[i].value);
OUTPUT:
RETVAL