« back to all changes in this revision
Viewing changes to GObject.xs
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Marc 'HE' Brockschmidt
- Date: 2004-06-14 13:23:01 UTC
- Revision ID: james.westby@ubuntu.com-20040614132301-3jexjlx4er0qzvwi
Tags: upstream-1.043
Import upstream version 1.043
- files added:
- t
added
removed
GObject.xs
1
/*
2
* Copyright (C) 2003-2004 by the gtk2-perl team (see the file AUTHORS for
3
* the full list)
4
*
5
* This library is free software; you can redistribute it and/or modify it
6
* under the terms of the GNU Library General Public License as published by
7
* the Free Software Foundation; either version 2.1 of the License, or (at your
8
* option) any later version.
9
*
10
* This library is distributed in the hope that it will be useful, but WITHOUT
11
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
13
* License for more details.
14
*
15
* You should have received a copy of the GNU Library General Public License
16
* along with this library; if not, write to the Free Software Foundation,
17
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307 USA.
18
*
19
* $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GObject.xs,v 1.37.2.1 2004/03/17 02:56:07 muppetman Exp $
20
*/
21
22
/*
23
* the POD directives in here will be stripped by xsubpp before compilation,
24
* and are intended to be extracted by podselect when creating xs api
25
* reference documentation. pod must NOT appear within C comments, because
26
* it gets replaced by a comment that says "embedded pod stripped".
27
*/
28
29
=head2 GObject
30
31
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.
32
33
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.
34
35
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.
36
37
Propers go to Marc Lehmann for dreaming most of this up.
38
39
=over
40
41
=cut
42
43
#include "gperl.h"
44
45
typedef struct _ClassInfo ClassInfo;
46
typedef struct _SinkFunc SinkFunc;
47
48
struct _ClassInfo {
49
GType gtype;
50
char * package;
51
HV * stash;
52
};
53
54
struct _SinkFunc {
55
GType gtype;
56
GPerlObjectSinkFunc func;
57
};
58
59
static GHashTable * types_by_type = NULL;
60
static GHashTable * types_by_package = NULL;
61
62
/* store outside of the class info maps any options we expect to be sparse;
63
* this will save us a fair amount of space. */
64
static GHashTable * nowarn_by_type = NULL;
65
static GArray * sink_funcs = NULL;
66
67
static GQuark wrapper_quark; /* this quark stores the object's wrapper sv */
68
69
70
/* thread safety locks for the modifiables above */
71
G_LOCK_DEFINE_STATIC (types_by_type);
72
G_LOCK_DEFINE_STATIC (types_by_package);
73
G_LOCK_DEFINE_STATIC (nowarn_by_type);
74
G_LOCK_DEFINE_STATIC (sink_funcs);
75
76
77
ClassInfo *
78
class_info_new (GType gtype,
79
const char * package)
80
{
81
ClassInfo * class_info;
82
83
class_info = g_new0 (ClassInfo, 1);
84
class_info->gtype = gtype;
85
class_info->package = g_strdup (package);
86
/* Taking a reference to the stash is not really correct,
87
* as the stash might be replaced, giving us the wrong stash.
88
* Fortunately doing this is not documented nor really supported,
89
* nor does perl cope with it gracefully. So this just shields us
90
* from segfaults. */
91
class_info->stash = (HV *)SvREFCNT_inc (gv_stashpv (package, 1));
92
93
return class_info;
94
}
95
96
void
97
class_info_destroy (ClassInfo * class_info)
98
{
99
if (class_info) {
100
SvREFCNT_dec (class_info->stash);
101
g_free (class_info->package);
102
g_free (class_info);
103
}
104
}
105
106
107
=item void gperl_register_object (GType gtype, const char * package)
108
109
tell the GPerl type subsystem what Perl package corresponds with a given
110
GObject by GType. automagically sets up @I<package>::ISA for you.
111
112
note that @ISA will not be created for gtype until gtype's parent has
113
been registered. if you are experiencing strange problems with a class'
114
@ISA not being set up, change the order in which you register them.
115
116
=cut
117
118
void
119
gperl_register_object (GType gtype,
120
const char * package)
121
{
122
GType parent_type;
123
ClassInfo * class_info;
124
125
G_LOCK (types_by_type);
126
G_LOCK (types_by_package);
127
128
if (!types_by_type) {
129
/* we put the same data pointer into each hash table, so we
130
* must only associate the destructor with one of them.
131
* also, for the string-keyed hashes, the keys will be
132
* destroyed by the ClassInfo destructor, so we don't need
133
* a key_destroy_func. */
134
types_by_type = g_hash_table_new_full (g_direct_hash,
135
g_direct_equal,
136
NULL,
137
(GDestroyNotify)
138
class_info_destroy);
139
types_by_package = g_hash_table_new_full (g_str_hash,
140
g_str_equal,
141
NULL,
142
NULL);
143
}
144
class_info = class_info_new (gtype, package);
145
g_hash_table_insert (types_by_type,
146
(gpointer) class_info->gtype, class_info);
147
g_hash_table_insert (types_by_package, class_info->package, class_info);
148
/* warn ("registered class %s to package %s\n", class_info->class, class_info->package); */
149
150
parent_type = g_type_parent (gtype);
151
if (parent_type != 0) {
152
static GList * pending_isa = NULL;
153
GList * i;
154
155
/*
156
* add this class to the list of pending ISA creations.
157
*
158
* "list of pending ISA creations?!?" you ask...
159
* to minimize the possible errors in setting up the class
160
* relationships, we only require the caller to provide
161
* the GType and name of the corresponding package; we don't
162
* also require the name of the parent class' package, since
163
* getting the parent GType is more likely to be error-free.
164
* (the developer setting up the registrations may have bad
165
* information, for example.)
166
*
167
* the nasty side effect is that the parent GType may not
168
* yet have been registered at the time the child type is
169
* registered. so, we keep a list of classes for which
170
* ISA has not yet been set up, and each time we run through
171
* this function, we'll try to eliminate as many as possible.
172
*
173
* since this one is fresh we append it to the list, so that
174
* we have a chance of registering its parent first.
175
*/
176
pending_isa = g_list_append (pending_isa, class_info);
177
178
/* handle whatever pending requests we can */
179
/* not a for loop, because we're modifying the list as we go */
180
i = pending_isa;
181
while (i != NULL) {
182
ClassInfo * parent_class_info;
183
184
/* NOTE: reusing class_info --- it's not the same as
185
* it was at the top of the function */
186
class_info = (ClassInfo*)(i->data);
187
188
parent_class_info = (ClassInfo *)
189
g_hash_table_lookup (types_by_type,
190
(gpointer) g_type_parent
191
(class_info->gtype));
192
193
if (parent_class_info) {
194
gperl_set_isa (class_info->package,
195
parent_class_info->package);
196
pending_isa = g_list_remove (pending_isa,
197
class_info);
198
/* go back to the beginning, in case we
199
* just registered one that is the base
200
* of several items earlier in the list.
201
* besides, it's dangerous to remove items
202
* while iterating... */
203
i = pending_isa;
204
} else {
205
/* go fish */
206
i = g_list_next (i);
207
}
208
}
209
}
210
211
G_UNLOCK (types_by_type);
212
G_UNLOCK (types_by_package);
213
}
214
215
216
=item void gperl_register_sink_func (GType gtype, GPerlObjectSinkFunc func)
217
218
Tell gperl_new_object() to use I<func> to claim ownership of objects derived
219
from I<gtype>.
220
221
gperl_new_object() always refs a GObject when wrapping it for the first time.
222
To have the Perl wrapper claim ownership of a GObject as part of
223
gperl_new_object(), you unref the object after ref'ing it. however, different
224
GObject subclasses have different ways to claim ownership; for example,
225
GtkObject simply requires you to call gtk_object_sink(). To make this concept
226
generic, this function allows you to register a function to be called when then
227
wrapper should claim ownership of the object. The I<func> registered for a
228
given I<type> will be called on any object for which C<< g_type_isa
229
(G_TYPE_OBJECT (object), type) >> succeeds.
230
231
If no sinkfunc is found for an object, g_object_unref() will be used.
232
233
Even though GObjects don't need sink funcs, we need to have them in Glib
234
as a hook for upstream objects. If we create a GtkObject (or any
235
other type of object which uses a different way to claim ownership) via
236
Glib::Object->new, any upstream wrappers, such as gtk2perl_new_object(), will
237
B<not> be called. Having a sink func facility down here enables us always to
238
do the right thing.
239
240
=cut
241
/*
242
* this stuff is directly inspired by pygtk. i didn't actually copy
243
* and paste the code, but it sure looks like i did, down to the names.
244
* hey, they were the obvious names!
245
*
246
* for the record, i think this is a rather dodgy way to do sink funcs
247
* --- it presumes that you'll find the right one first; i prepend new
248
* registrees in the hopes that this will work out, but nothing guarantees
249
* that this will work. to do it right, the wrappers need to have
250
* some form of inherited vtable or something... but i've had enough
251
* problems just getting the object caching working, so i can't really
252
* mess with that right now.
253
*/
254
void
255
gperl_register_sink_func (GType gtype,
256
GPerlObjectSinkFunc func)
257
{
258
SinkFunc sf;
259
260
G_LOCK (sink_funcs);
261
262
if (!sink_funcs)
263
sink_funcs = g_array_new (FALSE, FALSE, sizeof (SinkFunc));
264
sf.gtype = gtype;
265
sf.func = func;
266
g_array_prepend_val (sink_funcs, sf);
267
268
G_UNLOCK (sink_funcs);
269
}
270
271
/*
272
* helper for gperl_new_object; do whatever you have to do to this
273
* object to ensure that the calling code now owns the object. assumes
274
* the object has already been ref'd once. to do this, we look up the
275
* proper sink func; if none has been registered for this type, then
276
* just call g_object_unref.
277
*/
278
static void
279
gperl_object_take_ownership (GObject * object)
280
{
281
G_LOCK (sink_funcs);
282
283
if (sink_funcs) {
284
guint i;
285
for (i = 0 ; i < sink_funcs->len ; i++)
286
if (g_type_is_a (G_OBJECT_TYPE (object),
287
g_array_index (sink_funcs,
288
SinkFunc, i).gtype)) {
289
g_array_index (sink_funcs,
290
SinkFunc, i).func (object);
291
G_UNLOCK (sink_funcs);
292
return;
293
}
294
}
295
296
G_UNLOCK (sink_funcs);
297
298
g_object_unref (object);
299
}
300
301
302
=item void gperl_object_set_no_warn_unreg_subclass (GType gtype, gboolean nowarn)
303
304
how's that for a long and supposedly self-documenting function name!
305
(sorry...). basically, it does just as it says -- if I<nowarn> is true,
306
do not spew a warning if a GType derived from I<gtype> is not registered
307
with the bindings' type system. this is important for things like
308
GtkStyles (unregistered subclasses come from theme engines) and GdkGCs
309
(unregistered subclasses come from various gdk backends) for which it's not
310
possible or practical to force the registration of the classes. in
311
general, we want to warn about the unregistered types because it may mean
312
that a developer has forgotten something.
313
314
note: this assumes I<gtype> has already been registered with
315
gperl_register_object().
316
317
=cut
318
void
319
gperl_object_set_no_warn_unreg_subclass (GType gtype,
320
gboolean nowarn)
321
{
322
G_LOCK (nowarn_by_type);
323
324
if (!nowarn_by_type) {
325
if (!nowarn)
326
return;
327
nowarn_by_type = g_hash_table_new (g_direct_hash,
328
g_direct_equal);
329
}
330
g_hash_table_insert (nowarn_by_type,
331
(gpointer) gtype,
332
GINT_TO_POINTER (nowarn));
333
334
G_UNLOCK (nowarn_by_type);
335
}
336
337
static gboolean
338
gperl_object_get_no_warn_unreg_subclass (GType gtype)
339
{
340
gboolean result;
341
342
G_LOCK (nowarn_by_type);
343
344
if (!nowarn_by_type)
345
result = FALSE;
346
else
347
result = GPOINTER_TO_INT
348
(g_hash_table_lookup (nowarn_by_type,
349
(gpointer) gtype));
350
351
G_UNLOCK (nowarn_by_type);
352
353
return result;
354
}
355
356
357
=item const char * gperl_object_package_from_type (GType gtype)
358
359
get the package corresponding to I<gtype>; returns NULL if I<gtype>
360
is not registered.
361
362
=cut
363
const char *
364
gperl_object_package_from_type (GType gtype)
365
{
366
if (types_by_type) {
367
ClassInfo * class_info;
368
369
G_LOCK (types_by_type);
370
371
class_info = (ClassInfo *)
372
g_hash_table_lookup (types_by_type, (gpointer) gtype);
373
374
G_UNLOCK (types_by_type);
375
376
if (class_info)
377
return class_info->package;
378
else
379
return NULL;
380
} else
381
croak ("internal problem: gperl_object_package_from_type "
382
"called before any classes were registered");
383
return NULL; /* not reached */
384
}
385
386
387
=item HV * gperl_object_stash_from_type (GType gtype)
388
389
Get the stash corresponding to I<gtype>; returns NULL if I<gtype> is
390
not registered. The stash is useful for C<bless>ing.
391
392
=cut
393
394
HV *
395
gperl_object_stash_from_type (GType gtype)
396
{
397
if (types_by_type) {
398
ClassInfo * class_info;
399
400
G_LOCK (types_by_type);
401
402
class_info = (ClassInfo *)
403
g_hash_table_lookup (types_by_type, (gpointer) gtype);
404
405
G_UNLOCK (types_by_type);
406
407
if (class_info)
408
return class_info->stash;
409
else
410
return NULL;
411
} else
412
croak ("internal problem: gperl_object_stash_from_type "
413
"called before any classes were registered");
414
return NULL; /* not reached */
415
}
416
417
418
=item GType gperl_object_type_from_package (const char * package)
419
420
Inverse of gperl_object_package_from_type(), returns 0 if I<package>
421
is not registered.
422
423
=cut
424
425
GType
426
gperl_object_type_from_package (const char * package)
427
{
428
if (types_by_package) {
429
ClassInfo * class_info;
430
431
G_LOCK (types_by_package);
432
433
class_info = (ClassInfo *)
434
g_hash_table_lookup (types_by_package, package);
435
436
G_UNLOCK (types_by_package);
437
438
if (class_info)
439
return class_info->gtype;
440
else
441
return 0;
442
} else
443
croak ("internal problem: gperl_object_type_from_package "
444
"called before any classes were registered");
445
return 0; /* not reached */
446
}
447
448
/*
449
* this function is called whenever the gobject gets destroyed. this only
450
* happens if the perl object is no longer referenced anywhere else, so
451
* put it to final rest here.
452
*/
453
static void
454
gobject_destroy_wrapper (SV *obj)
455
{
456
if (PL_in_clean_objs)
457
return;
458
459
#ifdef NOISY
460
warn ("gobject_destroy_wrapper (%p)[%d]", obj, SvREFCNT (obj));
461
#endif
462
sv_unmagic (obj, PERL_MAGIC_ext);
463
464
/* we might want to optimize away the call to DESTROY here for non-perl classes. */
465
SvREFCNT_dec (obj);
466
}
467
468
469
=item SV * gperl_new_object (GObject * object, gboolean own)
470
471
Use this function to get the perl part of a GObject. If I<object>
472
has never been seen by perl before, a new, empty perl object will
473
be created and added to a private key under I<object>'s qdata. If
474
I<object> already has a perl part, a new reference to it will be
475
created. The gobject + perl object together form a combined object that
476
is properly refcounted, i.e. both parts will stay alive as long as at
477
least one of them is alive, and only when both perl object and gobject are
478
no longer referenced will both be freed.
479
480
The perl object will be blessed into the package corresponding to the GType
481
returned by calling G_OBJECT_TYPE() on I<object>; if that class has not
482
been registered via gperl_register_object(), this function will emit a
483
warning to that effect (with warn()), and attempt to bless it into the
484
first known class in the object's ancestry. Since Glib::Object is
485
already registered, you'll get a Glib::Object if you are lazy, and thus
486
this function can fail only if I<object> isn't descended from GObject,
487
in which case it croaks. (In reality, if you pass a non-GObject to this
488
function, you'll be lucky if you don't get a segfault, as there's not
489
really a way to trap that.) In practice these warnings can be unavoidable,
490
so you can use gperl_object_set_no_warn_unreg_subclass() to quell them
491
on a class-by-class basis.
492
493
However, when perl code is calling a GObject constructor (any function
494
which returns a new GObject), call gperl_new_object() with I<own> set to
495
%TRUE; this will cause the first matching sink function to be called
496
on the GObject to claim ownership of that object, so that it will be
497
destroyed when the perl object goes out of scope. The default sink func
498
is g_object_unref(); other types should supply the proper function;
499
e.g., GtkObject should use gtk_object_sink() here.
500
501
Returns the blessed perl object, or #&PL_sv_undef if object was #NULL.
502
503
=cut
504
505
SV *
506
gperl_new_object (GObject * object,
507
gboolean own)
508
{
509
SV *obj;
510
SV *sv;
511
512
/* take the easy way out if we can */
513
if (!object) {
514
#ifdef NOISY
515
warn ("gperl_new_object (NULL) => undef");
516
#endif
517
return &PL_sv_undef;
518
}
519
520
if (!G_IS_OBJECT (object))
521
croak ("object %p is not really a GObject", object);
522
523
/* fetch existing wrapper_data */
524
obj = (SV *)g_object_get_qdata (object, wrapper_quark);
525
526
if (!obj) {
527
/* create the perl object */
528
GType gtype = G_OBJECT_TYPE (object);
529
530
HV *stash = gperl_object_stash_from_type (gtype);
531
532
/* there are many possible cases in which we may be asked to
533
* create a wrapper for objects whose GTypes are not
534
* registered with us; we need to find the first known class
535
* and use that. see the docs for
536
* gperl_object_set_no_warn_unreg_subclass for more info. */
537
if (!stash) {
538
/* walk the anscestry to the first known GType.
539
* since GObject is registered to Glib::Object,
540
* this will always succeed. */
541
GType parent = gtype;
542
while (stash == NULL) {
543
parent = g_type_parent (parent);
544
stash = gperl_object_stash_from_type (parent);
545
}
546
if (!gperl_object_get_no_warn_unreg_subclass (parent))
547
warn ("GType '%s' is not registered with "
548
"GPerl; representing this object as "
549
"first known parent type '%s' instead",
550
g_type_name (gtype),
551
g_type_name (parent));
552
}
553
554
/*
555
* Create the "object", a hash.
556
*
557
* This does not need to be a HV, the only problem is finding
558
* out what to use, and HV is certainly the way to go for any
559
* built-in objects.
560
*/
561
562
/* this increases the combined object's refcount. */
563
obj = (SV *)newHV ();
564
/* attach magic */
565
sv_magic (obj, 0, PERL_MAGIC_ext, (const char *)object, 0);
566
567
/* this is the one refcount that represents all non-zero perl
568
* refcounts. it is just temporarily given to the gobject,
569
* DESTROY takes it back again. this effectively increases
570
* the combined refcount by one. */
571
g_object_ref (object);
572
573
/* create the wrapper to return, the _noinc decreases the
574
* combined refcount by one. */
575
sv = newRV_noinc (obj);
576
577
/* bless into the package */
578
sv_bless (sv, stash);
579
580
/* attach it to the gobject */
581
g_object_set_qdata_full (object,
582
wrapper_quark,
583
(gpointer)obj,
584
(GDestroyNotify)gobject_destroy_wrapper);
585
586
/* the noinc above is actually the trick, as it leaves the
587
* attached object's refcount artificially one too low,
588
* so DESTROY gets called when all handed-out refs are gone
589
* and we still have the object attached. DESTROY will
590
* then borrow the ref added by g_object_ref back, and
591
* thus will eventually trigger gobject destruction, which
592
* in turn will trigger perl wrapper destruction. */
593
594
#ifdef NOISY
595
warn ("gperl_new_object%d %s(%p)[%d] => %s (%p) (NEW)", own,
596
G_OBJECT_TYPE_NAME (object), object, object->ref_count,
597
gperl_object_package_from_type (G_OBJECT_TYPE (object)),
598
SvRV (sv));
599
#endif
600
} else {
601
/* create the wrapper to return, increases the combined
602
* refcount by one. */
603
sv = newRV_inc (obj);
604
605
/* Now we need to handle the case of a gobject that has
606
* been DESTROYed but gets "revived" later. This operation
607
* does not alter the refcount of the combined object.
608
* This can only happen if the call with own is not
609
* the first call. Unfortunately, this is the common case
610
* for gobjectclasses implemented in perl.
611
*/
612
if (object->ref_count == 1 && own) {
613
g_object_ref (object);
614
SvREFCNT_dec (obj);
615
}
616
617
}
618
619
#ifdef NOISY
620
warn ("gperl_new_object%d %s(%p)[%d] => %s (%p)[%d] (PRE-OWN)", own,
621
G_OBJECT_TYPE_NAME (object), object, object->ref_count,
622
gperl_object_package_from_type (G_OBJECT_TYPE (object)),
623
SvRV (sv), SvREFCNT (SvRV (sv)));
624
#endif
625
if (own)
626
gperl_object_take_ownership (object);
627
628
return sv;
629
}
630
631
632
=item GObject * gperl_get_object (SV * sv)
633
634
retrieve the GObject pointer from a Perl object. Returns NULL if I<sv> is not
635
linked to a GObject.
636
637
Note, this one is not safe -- in general you want to use
638
gperl_get_object_check().
639
640
=cut
641
642
GObject *
643
gperl_get_object (SV * sv)
644
{
645
MAGIC *mg;
646
647
if (!sv || !SvOK (sv) || !SvROK (sv) || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext)))
648
return NULL;
649
return (GObject *) mg->mg_ptr;
650
}
651
652
653
=item GObject * gperl_get_object_check (SV * sv, GType gtype);
654
655
croaks if I<sv> is undef or is not blessed into the package corresponding
656
to I<gtype>. use this for bringing parameters into xsubs from perl.
657
Returns the same as gperl_get_object() (provided it doesn't croak first).
658
659
=cut
660
661
GObject *
662
gperl_get_object_check (SV * sv,
663
GType gtype)
664
{
665
const char * package;
666
package = gperl_object_package_from_type (gtype);
667
if (!package)
668
croak ("INTERNAL: GType %s (%d) is not registered with GPerl!",
669
g_type_name (gtype), gtype);
670
if (!sv || !SvROK (sv) || !sv_derived_from (sv, package))
671
croak ("variable is not of type %s", package);
672
return gperl_get_object (sv);
673
}
674
675
676
=item SV * gperl_object_check_type (SV * sv, GType gtype)
677
678
Essentially the same as gperl_get_object_check().
679
680
FIXME this croaks if the types aren't compatible, but it would be useful if it just return FALSE instead.
681
682
=cut
683
684
SV *
685
gperl_object_check_type (SV * sv,
686
GType gtype)
687
{
688
gperl_get_object_check (sv, gtype);
689
return sv;
690
}
691
692
693
694
/* helper for g_object_[gs]et_parameter */
695
static void
696
init_property_value (GObject * object,
697
const char * name,
698
GValue * value)
699
{
700
GParamSpec * pspec;
701
pspec = g_object_class_find_property (G_OBJECT_GET_CLASS (object),
702
name);
703
if (!pspec) {
704
const char * classname =
705
gperl_object_package_from_type (G_OBJECT_TYPE (object));
706
if (!classname)
707
classname = G_OBJECT_TYPE_NAME (object);
708
croak ("type %s does not support property '%s'",
709
classname, name);
710
}
711
g_value_init (value, G_PARAM_SPEC_VALUE_TYPE (pspec));
712
}
713
714
715
=item typedef GObject GObject_noinc
716
717
=item typedef GObject GObject_ornull
718
719
=item newSVGObject(obj)
720
721
=item newSVGObject_noinc(obj)
722
723
=item SvGObject(sv)
724
725
=item SvGObject_ornull(sv)
726
727
728
=back
729
730
=cut
731
732
MODULE = Glib::Object PACKAGE = Glib::Object PREFIX = g_object_
733
734
=for object Glib::Object Bindings for GObject
735
=cut
736
737
=for position DESCRIPTION
738
739
=head1 DESCRIPTION
740
741
GObject is the base object class provided by the gobject library. It provides
742
object properties with a notification system, and emittable signals.
743
744
Glib::Object is the corresponding Perl object class. Glib::Objects are
745
represented by blessed hash references, with a magical connection to the
746
underlying C object.
747
748
=cut
749
750
BOOT:
751
gperl_register_object (G_TYPE_OBJECT, "Glib::Object");
752
wrapper_quark = g_quark_from_static_string ("Perl-wrapper-object");
753
754
755
void
756
DESTROY (SV *sv)
757
CODE:
758
GObject *object = gperl_get_object (sv);
759
760
if (!object) /* Happens on object destruction. */
761
return;
762
#ifdef NOISY
763
warn ("DESTROY< (%p)[%d] => %s (%p)[%d]",
764
object, object->ref_count,
765
gperl_object_package_from_type (G_OBJECT_TYPE (object)),
766
sv, SvREFCNT (SvRV(sv)));
767
#endif
768
/* gobject object still exists, so take back the refcount we lend it. */
769
/* this operation does NOT change the refcount of the combined object. */
770
771
if (PL_in_clean_objs) {
772
/* be careful during global destruction. basically,
773
* don't bother, since refcounting is no longer meaningful. */
774
sv_unmagic (SvRV (sv), PERL_MAGIC_ext);
775
776
g_object_steal_qdata (object, wrapper_quark);
777
} else {
778
SvREFCNT_inc (SvRV (sv));
779
}
780
g_object_unref (object);
781
#ifdef NOISY
782
warn ("DESTROY> (%p)[%d] => %s (%p)[%d]",
783
object, object->ref_count,
784
gperl_object_package_from_type (G_OBJECT_TYPE (object)),
785
sv, SvREFCNT (SvRV(sv)));
786
#endif
787
788
789
=for apidoc
790
791
=for signature object = $class->new (...)
792
793
=for arg ... of key/value pairs, property values to set on creation
794
795
Instantiate a Glib::Object of type I<$class>. Any key/value pairs in
796
I<...> are used to set properties on the new object; see C<set>.
797
This is designed to be inherited by Perl-derived subclasses (see
798
L<Glib::Object::Subclass>), but you can actually use it to create
799
any GObject-derived type.
800
801
=cut
802
SV *
803
g_object_new (class, ...)
804
const char *class
805
PREINIT:
806
int n_params = 0;
807
GParameter * params = NULL;
808
GType object_type;
809
GObject * object;
810
GObjectClass *oclass = NULL;
811
CODE:
812
#define FIRST_ARG 1
813
object_type = gperl_object_type_from_package (class);
814
if (!object_type)
815
croak ("%s is not registered with gperl as an object type",
816
class);
817
if (G_TYPE_IS_ABSTRACT (object_type))
818
croak ("cannot create instance of abstract (non-instantiatable)"
819
" type `%s'", g_type_name (object_type));
820
if (items > FIRST_ARG) {
821
int i;
822
if (NULL == (oclass = g_type_class_ref (object_type)))
823
croak ("could not get a reference to type class");
824
n_params = (items - FIRST_ARG) / 2;
825
params = g_new0 (GParameter, n_params);
826
for (i = 0 ; i < n_params ; i++) {
827
const char * key = SvPV_nolen (ST (FIRST_ARG+i*2+0));
828
GParamSpec * pspec;
829
pspec = g_object_class_find_property (oclass, key);
830
if (!pspec) {
831
/* clean up... */
832
int j;
833
for (j = 0 ; j < i ; j++)
834
g_value_unset (¶ms[j].value);
835
g_free (params);
836
/* and bail out. */
837
croak ("type %s does not support property '%s'",
838
class, key);
839
}
840
g_value_init (¶ms[i].value,
841
G_PARAM_SPEC_VALUE_TYPE (pspec));
842
/* note: this croaks if there is a problem. this is
843
* usually the right thing to do, because if it
844
* doesn't know how to convert the value, then there's
845
* something seriously wrong; however, it means that
846
* if there is a problem, all non-trivial values we've
847
* converted will be leaked. */
848
gperl_value_from_sv (¶ms[i].value,
849
ST (FIRST_ARG+i*2+1));
850
params[i].name = key; /* will be valid until this
851
* xsub is finished */
852
}
853
}
854
#undef FIRST_ARG
855
856
object = g_object_newv (object_type, n_params, params);
857
858
/* this wrapper *must* own this object!
859
* because we've been through initialization, the perl object
860
* will already exist at this point --- but this still causes
861
* gperl_object_take_ownership to be called. */
862
RETVAL = gperl_new_object (object, TRUE);
863
864
if (n_params) {
865
int i;
866
for (i = 0 ; i < n_params ; i++)
867
g_value_unset (¶ms[i].value);
868
g_free (params);
869
}
870
if (oclass)
871
g_type_class_unref (oclass);
872
OUTPUT:
873
RETVAL
874
875
876
=for apidoc Glib::Object::get
877
=for arg ... (list) list of property names
878
879
Fetch and return the values for the object properties named in I<...>.
880
881
=cut
882
883
=for apidoc Glib::Object::get_property
884
=for arg ... (__hide__)
885
886
Alias for C<get>.
887
888
=cut
889
890
void
891
g_object_get (object, ...)
892
GObject * object
893
ALIAS:
894
Glib::Object::get = 0
895
Glib::Object::get_property = 1
896
PREINIT:
897
GValue value = {0,};
898
int i;
899
PPCODE:
900
PERL_UNUSED_VAR (ix);
901
EXTEND (SP, items-1);
902
for (i = 1; i < items; i++) {
903
char *name = SvPV_nolen (ST (i));
904
init_property_value (object, name, &value);
905
g_object_get_property (object, name, &value);
906
PUSHs (sv_2mortal (gperl_sv_from_value (&value)));
907
g_value_unset (&value);
908
}
909
910
911
=for apidoc Glib::Object::set
912
=for signature $object->set (key => $value, ...)
913
=for arg ... (key/value pairs)
914
915
Set object properties.
916
917
=cut
918
919
=for apidoc Glib::Object::set_property
920
=for signature $object->set_property (key => $value, ...)
921
=for arg ... (__hide__)
922
923
Alias for C<set>.
924
925
=cut
926
927
void
928
g_object_set (object, ...)
929
GObject * object
930
ALIAS:
931
Glib::Object::set = 0
932
Glib::Object::set_property = 1
933
PREINIT:
934
GValue value = {0,};
935
int i;
936
CODE:
937
PERL_UNUSED_VAR (ix);
938
if (0 != ((items - 1) % 2))
939
croak ("set method expects name => value pairs "
940
"(odd number of arguments detected)");
941
942
for (i = 1; i < items; i += 2) {
943
char *name = SvPV_nolen (ST (i));
944
SV *newval = ST (i + 1);
945
946
init_property_value (object, name, &value);
947
gperl_value_from_sv (&value, newval);
948
g_object_set_property (object, name, &value);
949
g_value_unset (&value);
950
}
951
952
953
=for apidoc
954
955
Stops emission of "notify" signals on I<$object>. The signals are queued
956
until C<thaw_notify> is called on I<$object>.
957
958
=cut
959
void g_object_freeze_notify (GObject * object)
960
961
=for apidoc
962
963
Reverts the effect of a previous call to C<freeze_notify>. This causes all
964
queued "notify" signals on I<$object> to be emitted.
965
966
=cut
967
void g_object_thaw_notify (GObject * object)
968
969
=for apidoc
970
971
List all the object properties for I<$object_or_class_name>; returns them as
972
a list of hashes, containing these keys:
973
974
=over
975
976
=item name
977
978
=item type
979
980
=item owner_type
981
982
=item descr
983
984
=back
985
986
=cut
987
void
988
g_object_list_properties (object_or_class_name)
989
SV * object_or_class_name
990
PREINIT:
991
GType type;
992
GParamSpec ** props;
993
guint n_props = 0, i;
994
PPCODE:
995
if (object_or_class_name &&
996
SvOK (object_or_class_name) &&
997
SvROK (object_or_class_name)) {
998
GObject * object = SvGObject (object_or_class_name);
999
if (!object)
1000
croak ("wha? NULL object in list_properties");
1001
type = G_OBJECT_TYPE (object);
1002
} else {
1003
type = gperl_object_type_from_package
1004
(SvPV_nolen (object_or_class_name));
1005
if (!type)
1006
croak ("package %s is not registered with GPerl",
1007
SvPV_nolen (object_or_class_name));
1008
}
1009
if (G_TYPE_IS_OBJECT (type))
1010
{
1011
/* classes registered by perl are kept alive by the bindings.
1012
* those coming straight from C are not. if we had an actual
1013
* object, the class will be alive, but if we just had a
1014
* package, the class may not exist yet. thus, we'll have to
1015
* do an honest ref here, rather than a peek.
1016
*/
1017
GObjectClass * object_class = g_type_class_ref (type);
1018
props = g_object_class_list_properties (object_class, &n_props);
1019
g_type_class_unref (object_class);
1020
}
1021
#if GLIB_CHECK_VERSION(2,4,0)
1022
else if (G_TYPE_IS_INTERFACE (type))
1023
{
1024
gpointer iface = g_type_default_interface_ref (type);
1025
props = g_object_interface_list_properties (iface, &n_props);
1026
g_type_default_interface_unref (iface);
1027
}
1028
#endif
1029
else
1030
XSRETURN_EMPTY;
1031
#ifdef NOISY
1032
warn ("list_properties: %d properties\n", n_props);
1033
#endif
1034
for (i = 0; i < n_props; i++) {
1035
const gchar * pv;
1036
HV * property = newHV ();
1037
1038
hv_store (property, "name", 4,
1039
newSVpv (g_param_spec_get_name (props[i]), 0), 0);
1040
1041
/* map type names to package names, if possible */
1042
pv = gperl_package_from_type (props[i]->value_type);
1043
if (!pv) pv = g_type_name (props[i]->value_type);
1044
hv_store (property, "type", 4, newSVpv (pv, 0), 0);
1045
1046
pv = gperl_package_from_type (props[i]->owner_type);
1047
if (!pv) pv = g_type_name (props[i]->owner_type);
1048
hv_store (property, "owner_type", 10, newSVpv (pv, 0), 0);
1049
1050
/* this one can be NULL, it seems */
1051
pv = g_param_spec_get_blurb (props[i]);
1052
if (pv) hv_store (property, "descr", 5, newSVpv (pv, 0), 0);
1053
hv_store (property, "flags", 5, newSVGParamFlags (props[i]->flags), 0) ;
1054
1055
XPUSHs (sv_2mortal (newRV_noinc((SV*)property)));
1056
}
1057
g_free(props);
1058
1059
1060
=for apidoc
1061
1062
GObject provides an arbitrary data mechanism that assigns unsigned integers
1063
to key names. Functionality overlaps with the hash used as the Perl object
1064
instance, so we strongly recommend you use hash keys for your data storage.
1065
The GObject data values cannot store type information, so they are not safe
1066
to use for anything but integer values, and you really should use this method
1067
only if you know what you are doing.
1068
1069
=cut
1070
void
1071
g_object_set_data (object, key, data)
1072
GObject * object
1073
gchar * key
1074
SV * data
1075
CODE:
1076
if (SvROK (data) || !SvIOK (data))
1077
croak ("set_data only sets unsigned integers, use"
1078
" a key in the object hash for anything else");
1079
g_object_set_data (object, key, INT2PTR (gpointer, SvUV (data)));
1080
1081
1082
=for apidoc
1083
1084
Fetch the integer stored under the object data key I<$key>. These values do not
1085
have types; type conversions must be done manually. See C<set_data>.
1086
1087
=cut
1088
UV
1089
g_object_get_data (object, key)
1090
GObject * object
1091
gchar * key
1092
CODE:
1093
RETVAL = PTR2UV (g_object_get_data (object, key));
1094
OUTPUT:
1095
RETVAL
1096
1097
1098
###
1099
### rudimentary support for foreign objects.
1100
###
1101
1102
=for apidoc Glib::Object::new_from_pointer
1103
1104
=for arg pointer (unsigned) a C pointer value as an integer.
1105
1106
=for arg noinc (boolean) if true, do not increase the GObject's reference count when creating the Perl wrapper. this typically means that when the Perl wrapper will own the object. in general you don't want to do that, so the default is false.
1107
1108
Create a Perl Glib::Object reference for the C object pointed to by I<$pointer>.
1109
You should need this I<very> rarely; it's intended to support foreign objects.
1110
1111
NOTE: the cast from arbitrary integer to GObject may result in a core dump without
1112
warning, because the type-checking macro G_OBJECT() attempts to dereference the
1113
pointer to find a GTypeClass structure, and there is no portable way to validate
1114
the pointer.
1115
1116
=cut
1117
SV *
1118
new_from_pointer (class, pointer, noinc=FALSE)
1119
gpointer pointer
1120
gboolean noinc
1121
CODE:
1122
RETVAL = gperl_new_object (G_OBJECT (pointer), noinc);
1123
OUTPUT:
1124
RETVAL
1125
1126
1127
=for apidoc
1128
1129
Complement of C<new_from_pointer>.
1130
1131
=cut
1132
gpointer
1133
get_pointer (object)
1134
GObject * object
1135
CODE:
1136
RETVAL = object;
1137
OUTPUT:
1138
RETVAL
1139
1140
#if 0
1141
=for apidoc
1142
=for arg all if FALSE (or omitted) tie only properties for this object's class, if TRUE tie the properties of this and all parent classes.
1143
1144
A special method avaiable to Glib::Object derivatives, it uses perl's tie
1145
facilities to associate hash keys with the properties of the object. For
1146
example:
1147
1148
$button->tie_properties;
1149
# equivilent to $button->set (label => 'Hello World');
1150
$button->{label} = 'Hello World';
1151
print "the label is: ".$button->{label}."\n";
1152
1153
Attempts to write to read-only properties will croak, reading a write-only
1154
property will return '[write-only]'.
1155
1156
Care must be taken when using tie_properties with objects of types created with
1157
Glib::Object::Subclass as there may be clashes with existing hash keys that
1158
could cause infinite loops. The solution is to use custom property get/set
1159
functions to alter the storage locations of the properties.
1160
=cut
1161
void
1162
tie_properties (GObject * object, gboolean all=FALSE)
1163
1164
#endif
1165
Loggerhead is a web-based interface for Breezy
Version: 2.0.1