[perl-Glib] Allow for more than one PERL_MAGIC_ext magic

[Florian Ragwitz <rafl src gnome org>]

commit bfc4fd9b60b6e6771f6c4d65ab0b3155f709d448
Author: Florian Ragwitz <rafl debian org>
Date:   Wed Nov 24 22:42:35 2010 +0100

    Allow for more than one PERL_MAGIC_ext magic
    
    PERL_MAGIC_ext is there for extensions to use. We are such an extension, and
    therefore use it. However, up until now, we were still using it as if we lived
    in the year 2000 (i.e. when perl 5.6 was recent). From now on we're going to
    pretend it's 2003 and we have all the features perl 5.8 provides at our
    disposal.
    
    The feature we're interested in particularly is sv_magicext, which allows more
    than one magic of a certain kind to be attached to an SV, thereby allowing
    various extensions to co-exist in peace.
    
    Considering there can now be more than one PERL_MAGIC_ext per SV, we can't use
    mg_find or mg_unmagic anymore as those operate on the magic type only. Instead,
    we're adding gperl_find_mg and gperl_remove_mg, which use the address of our new
    (and empty) magic vtbl gperl_mg_vtbl to identify certain MAGIC pointers as ours.
    
    While all those new things are considered to be somewhat of an implementation
    detail, we do make them publically available for other parts of Glib to reuse.

 GBookmarkFile.xs |    4 +-
 GKeyFile.xs      |    4 +-
 GObject.xs       |   85 ++++++++++++++++++++++++++++++++++++++++++++++++++----
 GParamSpec.xs    |    4 +-
 Glib.exports     |    3 ++
 gperl.h          |    4 ++
 6 files changed, 92 insertions(+), 12 deletions(-)
---
diff --git a/GBookmarkFile.xs b/GBookmarkFile.xs
index aecf797..7d93c17 100644
--- a/GBookmarkFile.xs
+++ b/GBookmarkFile.xs
@@ -28,7 +28,7 @@ newSVGBookmarkFile (GBookmarkFile * bookmark_file)
 	HV * stash;
 
 	/* tie the key_file to our hash using some magic */
-	sv_magic ((SV *) bookmark, 0, PERL_MAGIC_ext, (const char *) bookmark_file, 0);
+	_gperl_attach_mg ((SV *) bookmark, bookmark_file);
 
 	/* wrap it, bless it, ship it. */
 	sv = newRV_noinc ((SV *) bookmark);
@@ -43,7 +43,7 @@ GBookmarkFile *
 SvGBookmarkFile (SV * sv)
 {
 	MAGIC * mg;
-	if (!sv || !SvROK (sv) || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext)))
+	if (!sv || !SvROK (sv) || !(mg = _gperl_find_mg (SvRV (sv))))
 		return NULL;
 	return (GBookmarkFile *) mg->mg_ptr;
 }
diff --git a/GKeyFile.xs b/GKeyFile.xs
index 8e95d00..2892607 100644
--- a/GKeyFile.xs
+++ b/GKeyFile.xs
@@ -65,7 +65,7 @@ newSVGKeyFile (GKeyFile * key_file)
 	HV * stash;
 
 	/* tie the key_file to our hash using some magic */
-	sv_magic ((SV*) key, 0, PERL_MAGIC_ext, (const char *) key_file, 0);
+	_gperl_attach_mg ((SV*) key, key_file);
 
 	/* wrap it, bless it, ship it. */
 	sv = newRV_noinc ((SV*) key);
@@ -80,7 +80,7 @@ GKeyFile *
 SvGKeyFile (SV * sv)
 {
 	MAGIC * mg;
-	if (! sv || !SvROK (sv) || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext)))
+	if (!sv || !SvROK (sv) || !(mg = _gperl_find_mg (SvRV (sv))))
 		return NULL;
 	return (GKeyFile *) mg->mg_ptr;
 }
diff --git a/GObject.xs b/GObject.xs
index a286f4f..29e4bc4 100644
--- a/GObject.xs
+++ b/GObject.xs
@@ -96,6 +96,76 @@ 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
+ * C<_gperl_find_mg> and removed again using C<_gperl_remove_mg>.
+ */
+
+void
+_gperl_attach_mg (SV * sv, void * ptr)
+{
+	sv_magicext (sv, NULL, PERL_MAGIC_ext, &gperl_mg_vtbl,
+		     (const char *)ptr, 0);
+}
+
+/*
+ * Retrieve the magic used to attach a pointer to the given C<sv> using
+ * C<_gperl_attach_mg>. The C<mg_ptr> member of the returned struct will contain
+ * the actual pointer attached to the scalar.
+ */
+
+MAGIC *
+_gperl_find_mg (SV * sv)
+{
+	MAGIC *mg;
+
+	if (SvTYPE (sv) < SVt_PVMG)
+		return NULL;
+
+	for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
+		if (mg->mg_type == PERL_MAGIC_ext
+		    && mg->mg_virtual == &gperl_mg_vtbl) {
+			assert (mg->mg_ptr);
+			return mg;
+		}
+	}
+
+	return NULL;
+}
+
+/*
+ * Remove the association between a pointer attached to C<sv> using
+ * C<_gperl_attach_mg> and the C<sv>.
+ */
+
+void
+_gperl_remove_mg (SV * sv)
+{
+	MAGIC *mg, *prevmagic = NULL, *moremagic = NULL;
+
+	if (SvTYPE (sv) < SVt_PVMG || !SvMAGIC (sv))
+		return;
+
+	for (mg = SvMAGIC (sv); mg; prevmagic = mg, mg = moremagic) {
+		moremagic = mg->mg_moremagic;
+
+		if (mg->mg_type == PERL_MAGIC_ext
+		    && mg->mg_virtual == &gperl_mg_vtbl)
+			break;
+	}
+
+	if (prevmagic) {
+		prevmagic->mg_moremagic = moremagic;
+	} else {
+		SvMAGIC_set (sv, moremagic);
+	}
+
+	mg->mg_moremagic = NULL;
+	Safefree (mg);
+}
+
 static ClassInfo *
 class_info_new (GType gtype,
 		const char * package)
@@ -705,7 +775,7 @@ gobject_destroy_wrapper (SV *obj)
               SvREFCNT ((SV*)REVIVE_UNDEAD(obj)));
 #endif
         obj = REVIVE_UNDEAD(obj);
-        sv_unmagic (obj, PERL_MAGIC_ext);
+        _gperl_remove_mg (obj);
 
         /* we might want to optimize away the call to DESTROY here for non-perl classes. */
         SvREFCNT_dec (obj);
@@ -801,7 +871,7 @@ gperl_new_object (GObject * object,
                 /* this increases the combined object's refcount. */
                 obj = (SV *)newHV ();
                 /* attach magic */
-                sv_magic (obj, 0, PERL_MAGIC_ext, (const char *)object, 0);
+                _gperl_attach_mg (obj, object);
 
                 /* The SV has a ref to the C object.  If we are to own this
                  * object, then any other references will be taken care of
@@ -874,6 +944,7 @@ gperl_new_object (GObject * object,
 }
 
 
+
 =item GObject * gperl_get_object (SV * sv)
 
 retrieve the GObject pointer from a Perl object.  Returns NULL if I<sv> is not
@@ -889,8 +960,10 @@ gperl_get_object (SV * sv)
 {
 	MAGIC *mg;
 
-	if (!gperl_sv_is_defined (sv) || !SvROK (sv) || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext)))
+	if (!gperl_sv_is_defined (sv) || !SvROK (sv)
+	    || !(mg = _gperl_find_mg (SvRV (sv))))
 		return NULL;
+
 	return (GObject *) mg->mg_ptr;
 }
 
@@ -916,9 +989,9 @@ gperl_get_object_check (SV * sv,
 		croak ("%s is not of type %s",
 		       gperl_format_variable_for_output (sv),
 		       package);
-	if (!mg_find (SvRV (sv), PERL_MAGIC_ext))
+	if (!_gperl_find_mg (SvRV (sv)))
 		croak ("%s is not a proper Glib::Object "
-		       "(it doesn't contain magic)",
+		       "(it doesn't contain the right magic)",
 		       gperl_format_variable_for_output (sv));
 
 	return gperl_get_object (sv);
@@ -1139,7 +1212,7 @@ DESTROY (SV *sv)
 	if (PL_in_clean_objs) {
                 /* be careful during global destruction. basically,
                  * don't bother, since refcounting is no longer meaningful. */
-                sv_unmagic (SvRV (sv), PERL_MAGIC_ext);
+                _gperl_remove_mg (SvRV (sv));
 
                 g_object_steal_qdata (object, wrapper_quark);
         } else {
diff --git a/GParamSpec.xs b/GParamSpec.xs
index fa7a027..49341d4 100644
--- a/GParamSpec.xs
+++ b/GParamSpec.xs
@@ -154,7 +154,7 @@ newSVGParamSpec (GParamSpec * pspec)
 	g_param_spec_sink (pspec);
 
 	property = newHV ();
-	sv_magic ((SV*)property, 0, PERL_MAGIC_ext, (const char*)pspec, 0);
+	_gperl_attach_mg ((SV*)property, pspec);
 
 
 	/* for hysterical raisins (backward compatibility with the old
@@ -202,7 +202,7 @@ GParamSpec *
 SvGParamSpec (SV * sv)
 {
 	MAGIC * mg;
-	if (!sv || !SvROK (sv) || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext)))
+	if (!sv || !SvROK (sv) || !(mg = _gperl_find_mg (SvRV (sv))))
 		return NULL;
 	return (GParamSpec*) mg->mg_ptr;
 }
diff --git a/Glib.exports b/Glib.exports
index 5b3c8cc..19c9f4b 100644
--- a/Glib.exports
+++ b/Glib.exports
@@ -24,7 +24,10 @@ SvGKeyFile
 SvGParamFlags
 SvGParamSpec
 SvGSignalFlags
+_gperl_attach_mg
 _gperl_call_XS
+_gperl_find_mg
+_gperl_remove_mg
 gperl_alloc_temp
 gperl_argv_free
 gperl_argv_new
diff --git a/gperl.h b/gperl.h
index 8afbc23..0028d71 100644
--- a/gperl.h
+++ b/gperl.h
@@ -198,6 +198,10 @@ GObject * gperl_get_object_check (SV * sv, GType gtype);
 
 SV * gperl_object_check_type (SV * sv, GType gtype);
 
+void _gperl_attach_mg (SV * sv, void * ptr);
+MAGIC * _gperl_find_mg (SV * sv);
+void _gperl_remove_mg (SV * sv);
+
 /* typedefs and macros for use with the typemap */
 typedef gchar gchar_length;
 typedef gchar gchar_own;