From 6ff38c2790dea060035b4175aa870de4adce00c9 Mon Sep 17 00:00:00 2001 From: Anno Siegel Date: Mon, 10 Jul 2006 23:30:15 +0200 Subject: [PATCH] FieldHash coverity-compliant Message-Id: <9C6C104C-8040-489A-BB35-40D22BC48AFC@mailbox.tu-berlin.de> p4raw-id: //depot/perl@28542 --- ext/Hash/Util/FieldHash/FieldHash.xs | 45 +++++++++++++--------- ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm | 37 +++++++++--------- ext/Hash/Util/FieldHash/t/02_function.t | 26 ++++++------- ext/Hash/Util/FieldHash/t/04_thread.t | 2 +- 4 files changed, 60 insertions(+), 50 deletions(-) diff --git a/ext/Hash/Util/FieldHash/FieldHash.xs b/ext/Hash/Util/FieldHash/FieldHash.xs index d6ecb80..91107dd 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 cf20f55..6575022 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. 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 and/or +C 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 and/or -C 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 or something similar in the accessors. The outstanding property of inside-out classes is their "inheritability". Like all inside-out classes, C is a I. 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, I, and I are supported by a data structure called -the I. This is currently the hash -C 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. 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, Eanno4000@zrz.tu-berlin.deE =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 8fed367..7796ff8 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 5197b90..b74d2c8 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; -- 2.7.4