Bug in Hash::Util::FieldHash

Message-Id: <DFEC2420-9301-40EC-A986-80D0290B2C8F@mailbox.tu-berlin.de>

p4raw-id: //depot/perl@31001

diff --git a/ext/Hash/Util/FieldHash/Changes b/ext/Hash/Util/FieldHash/Changes
index 841bce8..5ffc28f 100644 (file)
--- a/ext/Hash/Util/FieldHash/Changes
+++ b/ext/Hash/Util/FieldHash/Changes
@@ -5,3 +5,8 @@ Revision history for Perl extension Hash::Util::FieldHash.
                -A -g --skip-ppport -nHash::Util::FieldHash
       Fri Jun 23 22:31:59 CEST 2006
         - accepted as v5.9.4 DEVEL28420
+
+
+0.02  Fri Apr 20 22:22:57 CEST 2007
+        - Bugfix: string keys are now checked whether they represent
+        an object, so %fieldhash_clone = %fieldhash_orig works.

diff --git a/ext/Hash/Util/FieldHash/FieldHash.xs b/ext/Hash/Util/FieldHash/FieldHash.xs
index 6bc07cc..a749fc7 100644 (file)
--- a/ext/Hash/Util/FieldHash/FieldHash.xs
+++ b/ext/Hash/Util/FieldHash/FieldHash.xs
@@ -193,6 +193,11 @@ I32 HUF_watch_key(pTHX_ IV action, SV* field) {
     SV* keysv;
     if (mg) {
         keysv = mg->mg_obj;
+        if (keysv && !SvROK(keysv)) { /* is string an object-id? */
+            SV* obj = HUF_ask_trigger(keysv);
+            if (obj)
+                keysv = obj; /* use the object instead, so registry happens */
+        }
         if (keysv && SvROK(keysv)) {
             SV* ob_id = HUF_obj_id(keysv);
             mg->mg_obj = ob_id; /* key replacement */

diff --git a/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm b/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm
index 824873a..be1ab9a 100644 (file)
--- a/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm
+++ b/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm
@@ -15,7 +15,7 @@ our %EXPORT_TAGS = (
 );
 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 
-our $VERSION = '0.01_01';
+our $VERSION = '0.02';
 
 {
     require XSLoader;

diff --git a/ext/Hash/Util/FieldHash/t/02_function.t b/ext/Hash/Util/FieldHash/t/02_function.t
index 7796ff8..745ff3f 100644 (file)
--- a/ext/Hash/Util/FieldHash/t/02_function.t
+++ b/ext/Hash/Util/FieldHash/t/02_function.t
@@ -190,6 +190,23 @@ BEGIN { $n_tests += 6 }
     is( keys %$ob_reg, @obs, "all obs unregistered");
 }
 
+
+# direct hash assignment
+BEGIN { $n_tests += 4 }
+{
+    fieldhashes \ my( %f, %g, %h);
+    my $size = 6;
+    my @obs = map [], 1 .. $size;
+    @f{ @obs} = ( 1) x $size;
+    $g{ $_} = $f{ $_} for keys %f; # single assignment
+    %h = %f;                       # wholesale assignment
+    @obs = ();
+    is keys %$ob_reg, 0, "all keys collected";
+    is keys %f, 0, "orig garbage-collected";
+    is keys %g, 0, "single-copy garbage-dollected";
+    is keys %h, 0, "wholesale-copy garbage-dollected";
+}
+
 {
 
     BEGIN { $n_tests += 1 }