[PATCH 1/2] Allow for more than one PERL_MAGIC_ext magic

[Florian Ragwitz <rafl debian org>]

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       |   97 ++++++++++++++++++++++++++++++++++++++++++++++++++---
 GParamSpec.xs    |    4 +-
 Glib.exports     |    3 ++
 gperl.h          |    4 ++
 6 files changed, 104 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..52e5647 100644
--- a/GObject.xs
+++ b/GObject.xs
@@ -96,6 +96,88 @@ G_LOCK_DEFINE_STATIC (nowarn_by_type);
 G_LOCK_DEFINE_STATIC (sink_funcs);
 
 
+static MGVTBL gperl_mg_vtbl;
+
+=item void _gperl_attach_mg (SV * sv, void * ptr)
+
+This function is for internal use only. Do not use it in extensions.
+
+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>.
+
+=cut
+
+void
+_gperl_attach_mg (SV * sv, void * ptr)
+{
+       sv_magicext (sv, NULL, PERL_MAGIC_ext, &gperl_mg_vtbl,
+                    (const char *)ptr, 0);
+}
+
+=item MAGIC * _gperl_find_mg (SV * sv)
+
+This function is for internal use only. Do not use it in extensions.
+
+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.
+
+=cut
+
+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;
+}
+
+=item void * _gperl_find_mg (SV * sv)
+
+This function is for internal use only. Do not use it in extensions.
+
+Remove the association between a pointer attached to C<sv> using
+C<_gperl_attach_mg> and the C<sv>.
+
+=cut
+
+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 +787,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 +883,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 +956,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 +972,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 +1001,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 +1224,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;
-- 
1.7.2.3