FieldHash coverity-compliant

Message-Id: <9C6C104C-8040-489A-BB35-40D22BC48AFC@mailbox.tu-berlin.de>

p4raw-id: //depot/perl@28542

4 files changed, 60 insertions, 50 deletions

diff --git a/ext/Hash/Util/FieldHash/FieldHash.xs b/ext/Hash/Util/FieldHash/FieldHash.xs
index d6ecb8027f..91107ddd8d 100644
--- a/ext/Hash/Util/FieldHash/FieldHash.xs
+++ b/ext/Hash/Util/FieldHash/FieldHash.xs
@@ -4,13 +4,12 @@
 
 /* support for Hash::Util::FieldHash, prefix HUF_ */
 
-/* The object registry, a package variable */
-#define HUF_OB_REG "Hash::Util::FieldHash::ob_reg"
+/* A Perl sub that returns a hashref to the object registry */
+#define HUF_OB_REG "Hash::Util::FieldHash::_ob_reg"
 /* Magic cookies to recognize object id's.  Hi, Eva, David */
 #define HUF_COOKIE 2805.1980
 #define HUF_REFADDR_COOKIE 1811.1976
 
-
 /* For global cache of object registry */
 #define MY_CXT_KEY "Hash::Util::FieldHash::_guts" XS_VERSION
 typedef struct {
@@ -18,6 +17,20 @@ typedef struct {
 } my_cxt_t;
 START_MY_CXT
 
+/* Inquire the object registry (a lexical hash) from perl */
+HV* HUF_get_ob_reg(void) {
+    dSP;
+    I32 items = call_pv(HUF_OB_REG, G_SCALAR|G_NOARGS);
+    SPAGAIN;
+    if (items == 1) {
+        SV* ref = POPs;
+        PUTBACK;
+        if (ref && SvROK(ref) && SvTYPE(SvRV(ref)) == SVt_PVHV)
+            return (HV*)SvRV(ref);
+    }
+    Perl_die(aTHX_ "Can't get object registry hash");
+}
+
 /* Deal with global context */
 #define HUF_INIT 1
 #define HUF_CLONE 0
@@ -26,13 +39,13 @@ START_MY_CXT
 void HUF_global(I32 how) {
     if (how == HUF_INIT) {
         MY_CXT_INIT;
-        MY_CXT.ob_reg = get_hv(HUF_OB_REG, 1);
+        MY_CXT.ob_reg = HUF_get_ob_reg();
     } else if (how == HUF_CLONE) {
         MY_CXT_CLONE;
-        MY_CXT.ob_reg = get_hv(HUF_OB_REG, 0);
+        MY_CXT.ob_reg = HUF_get_ob_reg();
     } else if (how == HUF_RESET) {
         dMY_CXT;
-        MY_CXT.ob_reg = get_hv(HUF_OB_REG, 0);
+        MY_CXT.ob_reg = HUF_get_ob_reg();
     }
 }
 
@@ -56,14 +69,14 @@ SV* HUF_field_id(SV* obj) {
     return HUF_id(obj, 0.0);
 }
 
-/* object id (may be different in future) */
+/* object id (same as plain, may be different in future) */
 SV* HUF_obj_id(SV* obj) {
     return HUF_id(obj, 0.0);
 }
 
 /* set up uvar magic for any sv */
 void HUF_add_uvar_magic(
-    SV* sv,                    /* the sv to enchant, visible to * get/set */
+    SV* sv,                    /* the sv to enchant, visible to get/set */
     I32(* val)(pTHX_ IV, SV*), /* "get" function */
     I32(* set)(pTHX_ IV, SV*), /* "set" function */
     I32 index,                 /* get/set will see this */
@@ -155,6 +168,8 @@ void HUF_mark_field(SV* trigger, SV* field) {
     hv_store_ent(field_tab, field_id, field_ref, 0);
 }
 
+/* These constants are not in the API.  If they ever change in hv.c this code
+ * must be updated */
 #define HV_FETCH_ISSTORE   0x01
 #define HV_FETCH_ISEXISTS  0x02
 #define HV_FETCH_LVALUE    0x04
@@ -166,7 +181,10 @@ void HUF_mark_field(SV* trigger, SV* field) {
  * in hv.c */
 I32 HUF_watch_key(pTHX_ IV action, SV* field) {
     MAGIC* mg = mg_find(field, PERL_MAGIC_uvar);
-    SV* keysv = mg->mg_obj;
+    SV* keysv;
+    if (!mg)
+        Perl_die(aTHX_ "Rogue call of 'HUF_watch_key'");
+    keysv = mg->mg_obj;
     if (keysv && SvROK(keysv)) {
         SV* ob_id = HUF_obj_id(keysv);
         mg->mg_obj = ob_id; /* key replacement */
@@ -285,15 +303,6 @@ CODE:
         HUF_fix_objects();
     }
 
-SV*
-_get_obj_id(SV* obj)
-CODE:
-    RETVAL = NULL;
-    if (SvROK(obj))
-        RETVAL = HUF_obj_id(obj);
-OUTPUT:
-    RETVAL
-
 void
 _active_fields(SV* obj)
 PPCODE:
diff --git a/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm b/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm
index cf20f55876..6575022efa 100644
--- a/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm
+++ b/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm
@@ -3,7 +3,6 @@ package Hash::Util::FieldHash;
 use 5.009004;
 use strict;
 use warnings;
-use Carp qw( croak);
 use Scalar::Util qw( reftype);
 
 require Exporter;
@@ -15,14 +14,13 @@ our %EXPORT_TAGS = (
     )],
 );
 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
-our @EXPORT = qw(
-);
 
 our $VERSION = '0.01';
 
 {
     require XSLoader;
-    our %ob_reg; # silence possible 'once' warning in XSLoader
+    my %ob_reg; # private object registry
+    sub _ob_reg { \ %ob_reg }
     XSLoader::load('Hash::Util::FieldHash', $VERSION);
 }
 
@@ -47,10 +45,10 @@ Hash::Util::FieldHash - Associate references with data
 =head1 SYNOPSIS
 
   use Hash::Util qw(fieldhash fieldhashes);
-  
+
   # Create a single field hash
   fieldhash my %foo;
-  
+
   # Create three at once...
   fieldhashes \ my(%foo, %bar, %baz);
   # ...or any number
@@ -199,11 +197,14 @@ as
 instead of importing it from C<Scalar::Util>.  It should now be possible
 to disable DESTROY and CLONE.  Note that while it isn't disabled,
 DESTROY will be called before the garbage collection of field hashes,
-so it will be invoked with a functional object.
+so it will be invoked with a functional object and will continue to
+function.
+
+It is not desirable to import the functions C<fieldhash> and/or
+C<fieldhashes> into every class that is going to use them.  They
+are only used once to set up the class.  When the class is up and running,
+these functions serve no more purpose.
 
-It is not necessary to import the functions C<fieldhash> and/or
-C<fieldhashes> into every class that is going to use them.  When
-the class is up and running, these functions have no business there.
 If there are only a few field hashes to declare, it is simplest to
 
     use Hash::Util::FieldHash;
@@ -267,8 +268,8 @@ C<refaddr> or something similar in the accessors.
 The outstanding property of inside-out classes is their "inheritability".
 Like all inside-out classes, C<TimeStamp> is a I<universal base class>.
 We can put it on the C<@ISA> list of arbitrary classes and its methods
-will just work, no matter how the host class is constructed.  This is
-demonstrated by the following program:
+will just work, no matter how the host class is constructed.  No traditional
+Perl class allows that.  The following program demonstrates the feat:
 
     # Make a sample of objects to add time stamps to.
 
@@ -280,10 +281,11 @@ demonstrated by the following program:
         IO::Handle->new(),
         qr/abc/,                         # in class Regexp
         bless( [], 'Boing'),             # made up on the spot
+        # add more
     );
 
     # Prepare for use with TimeStamp
-    
+
     for ( @objects ) {
         no strict 'refs';
         push @{ ref() . '::ISA' }, 'TimeStamp';
@@ -381,10 +383,9 @@ the referenced object.
 
 The three features of key hashes, I<key replacement>, I<thread support>,
 and I<garbage collection> are supported by a data structure called
-the I<object registry>.  This is currently the hash
-C<Hash::Utils::FieldHash::ob_reg> though there may be a more private
-place for it in the future.  An "object" is any reference (blessed
-or unblessed) that has been used as a field hash key.
+the I<object registry>.  This is a private hash where every object
+is stored.  An "object" in this sense is any reference (blessed or
+unblessed) that has been used as a field hash key.
 
 The object registry keeps track of references that have been used as
 field hash keys.  The keys are generated from the reference address
@@ -433,7 +434,7 @@ Anno Siegel, E<lt>anno4000@zrz.tu-berlin.deE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
-Copyright (C) 2006 by (icke)
+Copyright (C) 2006 by (Anno Siegel)
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself, either Perl version 5.8.7 or,
diff --git a/ext/Hash/Util/FieldHash/t/02_function.t b/ext/Hash/Util/FieldHash/t/02_function.t
index 8fed367d3a..7796ff8944 100644
--- a/ext/Hash/Util/FieldHash/t/02_function.t
+++ b/ext/Hash/Util/FieldHash/t/02_function.t
@@ -12,6 +12,7 @@ use Test::More;
 my $n_tests = 0;
 
 use Hash::Util::FieldHash qw( :all);
+my $ob_reg = Hash::Util::FieldHash::_ob_reg;
 
 #########################
 
@@ -26,7 +27,6 @@ BEGIN {
 
 BEGIN { $n_tests += 3 }
 {
-    my $ob_reg = \ %Hash::Util::FieldHash::ob_reg;
     {
         my $obj = {};
         {
@@ -98,7 +98,7 @@ for my $preload ( [], [ map {}, 1 .. 3] ) {
             my ( $val) = grep $_ eq $type, values %f;
             is( $val, $type, "$type visible$pre");
             is( 
-                keys %Hash::Util::FieldHash::ob_reg,
+                keys %$ob_reg,
                 1 + @$preload,
                 "$type obj registered$pre"
             );
@@ -107,7 +107,7 @@ for my $preload ( [], [ map {}, 1 .. 3] ) {
     }
     
     # Garbage collection collectively
-    is( keys %Hash::Util::FieldHash::ob_reg, @$preload, "no objs remaining$pre");
+    is( keys %$ob_reg, @$preload, "no objs remaining$pre");
     {
         my @refs = map gen_ref( $_), @test_types;
         @f{ @refs} = @test_types;
@@ -116,16 +116,16 @@ for my $preload ( [], [ map {}, 1 .. 3] ) {
             "all types present$pre",
         );
         is(
-            keys %Hash::Util::FieldHash::ob_reg,
+            keys %$ob_reg,
             @test_types + @$preload,
             "all types registered$pre",
         );
     }
     die "preload gone" unless defined $preload;
     ok( eq_set( [ values %f], \ @preval), "all types gone$pre");
-    is( keys %Hash::Util::FieldHash::ob_reg, @$preload, "all types unregistered$pre");
+    is( keys %$ob_reg, @$preload, "all types unregistered$pre");
 }
-is( keys %Hash::Util::FieldHash::ob_reg, 0, "preload gone after loop");
+is( keys %$ob_reg, 0, "preload gone after loop");
 
 # big key sets
 BEGIN { $n_tests += 8 }
@@ -137,14 +137,14 @@ BEGIN { $n_tests += 8 }
         $f{ $_} = 1 for @refs;
         is( keys %f, $size, "many keys singly");
         is(
-            keys %Hash::Util::FieldHash::ob_reg,
+            keys %$ob_reg,
             $size,
             "many objects singly",
         );
     }
     is( keys %f, 0, "many keys singly gone");
     is(
-        keys %Hash::Util::FieldHash::ob_reg,
+        keys %$ob_reg,
         0,
         "many objects singly unregistered",
     );
@@ -154,14 +154,14 @@ BEGIN { $n_tests += 8 }
         @f{ @refs } = ( 1) x @refs;
         is( keys %f, $size, "many keys at once");
         is(
-            keys %Hash::Util::FieldHash::ob_reg,
+            keys %$ob_reg,
             $size,
             "many objects at once",
         );
     }
     is( keys %f, 0, "many keys at once gone");
     is(
-        keys %Hash::Util::FieldHash::ob_reg,
+        keys %$ob_reg,
         0,
         "many objects at once unregistered",
     );
@@ -179,15 +179,15 @@ BEGIN { $n_tests += 6 }
     }
     my $err = grep keys %$_ != @obs, @fields;
     is( $err, 0, "$n_obs entries in $n_fields fields");
-    is( keys %Hash::Util::FieldHash::ob_reg, @obs, "$n_obs obs registered");
+    is( keys %$ob_reg, @obs, "$n_obs obs registered");
     pop @obs;
     $err = grep keys %$_ != @obs, @fields;
     is( $err, 0, "one entry gone from $n_fields fields");
-    is( keys %Hash::Util::FieldHash::ob_reg, @obs, "one ob unregistered");
+    is( keys %$ob_reg, @obs, "one ob unregistered");
     @obs = ();
     $err = grep keys %$_ != @obs, @fields;
     is( $err, 0, "all entries gone from $n_fields fields");
-    is( keys %Hash::Util::FieldHash::ob_reg, @obs, "all obs unregistered");
+    is( keys %$ob_reg, @obs, "all obs unregistered");
 }
 
 {
diff --git a/ext/Hash/Util/FieldHash/t/04_thread.t b/ext/Hash/Util/FieldHash/t/04_thread.t
index 5197b907e1..b74d2c8052 100644
--- a/ext/Hash/Util/FieldHash/t/04_thread.t
+++ b/ext/Hash/Util/FieldHash/t/04_thread.t
@@ -12,6 +12,7 @@ use Test::More;
 my $n_tests;
 
 use Hash::Util::FieldHash qw( :all);
+my $ob_reg = Hash::Util::FieldHash::_ob_reg;
 
 {
     my $n_basic;
@@ -19,7 +20,6 @@ use Hash::Util::FieldHash qw( :all);
         $n_basic = 6; # 6 tests per call of basic_func()
         $n_tests += 5*$n_basic;
     }
-    my $ob_reg = \ %Hash::Util::FieldHash::ob_reg;
     my %h;
     fieldhash %h;