[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       |   68 +++++++++++++++++++++++++++++++++++++++++++++++++----
 GParamSpec.xs    |    4 +-
 Glib.exports     |    3 ++
 gperl.h          |    4 +++
 6 files changed, 75 insertions(+), 12 deletions(-)

diff --git a/GBookmarkFile.xs b/GBookmarkFile.xs
index aecf797..1ea439d 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 (!(mg = gperl_find_mg (SvRV (sv))))
                return NULL;
        return (GBookmarkFile *) mg->mg_ptr;
 }
diff --git a/GKeyFile.xs b/GKeyFile.xs
index 8e95d00..9523d10 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 (!(mg = gperl_find_mg (SvRV (sv))))
                return NULL;
        return (GKeyFile *) mg->mg_ptr;
 }
diff --git a/GObject.xs b/GObject.xs
index a286f4f..0e03365 100644
--- a/GObject.xs
+++ b/GObject.xs
@@ -96,6 +96,59 @@ G_LOCK_DEFINE_STATIC (nowarn_by_type);
 G_LOCK_DEFINE_STATIC (sink_funcs);
 
 
+static MGVTBL gperl_mg_vtbl;
+
+void
+gperl_attach_mg (SV * sv, void * ptr)
+{
+       sv_magicext (sv, NULL, PERL_MAGIC_ext, &gperl_mg_vtbl,
+                    (const char *)ptr, 0);
+}
+
+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;
+}
+
+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 +758,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 +854,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 +927,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 +943,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 +972,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 +1195,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..cc2cedb 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 (!(mg = gperl_find_mg (SvRV (sv))))
                return NULL;
        return (GParamSpec*) mg->mg_ptr;
 }
diff --git a/Glib.exports b/Glib.exports
index 5b3c8cc..9a03d7d 100644
--- a/Glib.exports
+++ b/Glib.exports
@@ -29,6 +29,7 @@ gperl_alloc_temp
 gperl_argv_free
 gperl_argv_new
 gperl_argv_update
+gperl_attach_mg
 gperl_boxed_package_from_type
 gperl_boxed_type_from_package
 gperl_callback_destroy
@@ -44,6 +45,7 @@ gperl_convert_flag_one
 gperl_convert_flags
 gperl_croak_gerror
 gperl_default_boxed_wrapper_class
+gperl_find_mg
 gperl_filename_from_sv
 gperl_format_variable_for_output
 gperl_fundamental_package_from_type
@@ -79,6 +81,7 @@ gperl_register_object_alias
 gperl_register_param_spec
 gperl_register_sink_func
 gperl_remove_exception_handler
+gperl_remove_mg
 gperl_run_exception_handlers
 gperl_set_isa
 gperl_signal_connect
diff --git a/gperl.h b/gperl.h
index 8afbc23..3d924f4 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