« back to all changes in this revision
Viewing changes to GObject.xs
- browse files at revision 3
- compare with another revision
- download diff
- download tarball
- view history from revision 3
- Committer: Bazaar Package Importer
- Author(s): Marc 'HE' Brockschmidt
- Date: 2005-04-13 11:35:45 UTC
- mfrom: (1.2.1 upstream) (2.1.1 hoary)
- Revision ID: james.westby@ubuntu.com-20050413113545-vmtsd6lz11fuuvhy
Tags: 1:1.081-1
New upstream release.
- files added:
- debian/watch
- files modified:
- ChangeLog
added
removed
GObject.xs
16
16
* along with this library; if not, write to the Free Software Foundation,
17
17
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307 USA.
18
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 $
19
* $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GObject.xs,v 1.47 2004/07/19 01:05:18 muppetman Exp $
20
20
*/
21
21
22
22
/*
48
48
struct _ClassInfo {
49
49
GType gtype;
50
50
char * package;
51
HV * stash;
52
51
};
53
52
54
53
struct _SinkFunc {
66
65
67
66
static GQuark wrapper_quark; /* this quark stores the object's wrapper sv */
68
67
68
/* what should be done here */
69
#define GPERL_THREAD_SAFE !GPERL_DISABLE_THREADSAFE
70
71
#if GPERL_THREAD_SAFE
72
/* keep a list of all gobjects */
73
static gboolean perl_gobject_tracking = FALSE;
74
static GHashTable * perl_gobjects = NULL;
75
G_LOCK_DEFINE_STATIC (perl_gobjects);
76
#endif
69
77
70
78
/* thread safety locks for the modifiables above */
71
79
G_LOCK_DEFINE_STATIC (types_by_type);
83
91
class_info = g_new0 (ClassInfo, 1);
84
92
class_info->gtype = gtype;
85
93
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
94
93
95
return class_info;
94
96
}
97
99
class_info_destroy (ClassInfo * class_info)
98
100
{
99
101
if (class_info) {
100
SvREFCNT_dec (class_info->stash);
101
102
g_free (class_info->package);
102
103
g_free (class_info);
103
104
}
394
395
HV *
395
396
gperl_object_stash_from_type (GType gtype)
396
397
{
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 */
398
const char * package = gperl_object_package_from_type (gtype);
399
if (package)
400
return gv_stashpv (package, TRUE);
401
else
402
return NULL;
415
403
}
416
404
417
405
625
613
if (own)
626
614
gperl_object_take_ownership (object);
627
615
616
#if GPERL_THREAD_SAFE
617
if(perl_gobject_tracking)
618
{
619
G_LOCK (perl_gobjects);
620
/*g_printerr ("adding object: 0x%p - %d\n", object, object->ref_count);*/
621
if (!perl_gobjects)
622
perl_gobjects = g_hash_table_new (g_direct_hash, g_direct_equal);
623
g_hash_table_insert (perl_gobjects, (gpointer)object, (gpointer)1);
624
G_UNLOCK (perl_gobjects);
625
}
626
#endif
627
628
628
return sv;
629
629
}
630
630
668
668
croak ("INTERNAL: GType %s (%d) is not registered with GPerl!",
669
669
g_type_name (gtype), gtype);
670
670
if (!sv || !SvROK (sv) || !sv_derived_from (sv, package))
671
croak ("variable is not of type %s", package);
671
croak ("%s is not of type %s",
672
gperl_format_variable_for_output (sv),
673
package);
674
672
675
return gperl_get_object (sv);
673
676
}
674
677
729
732
730
733
=cut
731
734
735
/*
736
* $sv = $object->{name}
737
*
738
* if the key doesn't exist with name, convert - to _ and try again.
739
* that is, support both "funny-name" and "funny_name".
740
*
741
* if create is true, autovivify the key (and always return a value).
742
* if create is false, returns NULL is there is no such key.
743
*/
744
SV *
745
_gperl_fetch_wrapper_key (GObject * object,
746
const char * name,
747
gboolean create)
748
{
749
SV ** svp;
750
SV * svname;
751
HV * wrapper_hash;
752
wrapper_hash = g_object_get_qdata (object, wrapper_quark);
753
svname = newSVpv (name, strlen (name));
754
svp = hv_fetch (wrapper_hash, SvPV_nolen (svname), SvLEN (svname)-1,
755
FALSE); /* never create on the first try; prefer
756
* prefer to create the second version. */
757
if (!svp) {
758
/* the key doesn't exist with that name. do s/-/_/g and
759
* try again. */
760
register char * c;
761
for (c = SvPV_nolen (svname); c <= SvEND (svname) ; c++)
762
if (*c == '-')
763
*c = '_';
764
svp = hv_fetch (wrapper_hash,
765
SvPV_nolen (svname), SvLEN (svname)-1,
766
create);
767
}
768
SvREFCNT_dec (svname);
769
770
return (svp ? *svp : NULL);
771
}
772
773
#if GPERL_THREAD_SAFE
774
static void
775
_inc_ref_and_count (GObject * key, gint value, gpointer user_data)
776
{
777
PERL_UNUSED_VAR (user_data);
778
g_object_ref (key);
779
g_hash_table_replace (perl_gobjects, key, (gpointer)++value);
780
}
781
#endif
782
783
732
784
MODULE = Glib::Object PACKAGE = Glib::Object PREFIX = g_object_
733
785
786
#if GPERL_THREAD_SAFE
787
788
void
789
CLONE (gchar * class)
790
CODE:
791
if (perl_gobject_tracking && strcmp (class, "Glib::Object") == 0)
792
{
793
G_LOCK (perl_gobjects);
794
/*g_printerr ("we're in clone: %s\n", class);*/
795
g_hash_table_foreach (perl_gobjects,
796
(GHFunc)_inc_ref_and_count, NULL);
797
G_UNLOCK (perl_gobjects);
798
}
799
800
#endif
801
802
=for apidoc set_threadsafe
803
Enables/disables threadsafe gobject tracking. Returns whether or not tracking
804
will be successful and thus whether using perl ithreads will be possible.
805
=cut
806
gboolean
807
set_threadsafe (class, gboolean threadsafe)
808
CODE:
809
#if GPERL_THREAD_SAFE
810
RETVAL = perl_gobject_tracking = threadsafe;
811
#else
812
RETVAL = FALSE;
813
#endif
814
OUTPUT:
815
RETVAL
816
734
817
=for object Glib::Object Bindings for GObject
735
818
=cut
736
819
777
860
} else {
778
861
SvREFCNT_inc (SvRV (sv));
779
862
}
863
#if GPERL_THREAD_SAFE
864
if(perl_gobject_tracking)
865
{
866
gint count;
867
G_LOCK (perl_gobjects);
868
count = (int)g_hash_table_lookup (perl_gobjects, object);
869
count--;
870
if (count > 0)
871
{
872
/*g_printerr ("decing: %p - %d\n", object, count);*/
873
g_hash_table_replace (perl_gobjects, object,
874
(gpointer)count);
875
}
876
else
877
{
878
/*g_printerr ("removing: %p\n", object);*/
879
g_hash_table_remove (perl_gobjects, object);
880
}
881
G_UNLOCK (perl_gobjects);
882
}
883
#endif
780
884
g_object_unref (object);
781
885
#ifdef NOISY
886
warn ("DESTROY> (%p) done\n", object);
887
/*
782
888
warn ("DESTROY> (%p)[%d] => %s (%p)[%d]",
783
889
object, object->ref_count,
784
890
gperl_object_package_from_type (G_OBJECT_TYPE (object)),
785
891
sv, SvREFCNT (SvRV(sv)));
892
*/
786
893
#endif
787
894
788
789
895
=for apidoc
790
896
791
897
=for signature object = $class->new (...)
949
1055
g_value_unset (&value);
950
1056
}
951
1057
1058
=for apidoc
1059
1060
Emits a "notify" signal for the property I<$property> on I<$object>.
1061
1062
=cut
1063
void g_object_notify (GObject * object, const gchar * property_name)
952
1064
953
1065
=for apidoc
954
1066
1031
1143
#ifdef NOISY
1032
1144
warn ("list_properties: %d properties\n", n_props);
1033
1145
#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
}
1146
for (i = 0; i < n_props; i++)
1147
XPUSHs (sv_2mortal (newSVGParamSpec (props[i])));
1057
1148
g_free(props);
1058
1149
1059
1150
Loggerhead is a web-based interface for Breezy
Version: 2.0.1