Change 28542 by [EMAIL PROTECTED] on 2006/07/11 08:06:26
Subject: [PATCH] FieldHash coverity-compliant
From: Anno Siegel <[EMAIL PROTECTED]>
Date: Mon, 10 Jul 2006 21:30:15 +0200
Message-Id: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/ext/Hash/Util/FieldHash/FieldHash.xs#6 edit
... //depot/perl/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm#2 edit
... //depot/perl/ext/Hash/Util/FieldHash/t/02_function.t#4 edit
... //depot/perl/ext/Hash/Util/FieldHash/t/04_thread.t#3 edit
Differences ...
==== //depot/perl/ext/Hash/Util/FieldHash/FieldHash.xs#6 (text) ====
Index: perl/ext/Hash/Util/FieldHash/FieldHash.xs
--- perl/ext/Hash/Util/FieldHash/FieldHash.xs#5~28478~ 2006-07-04
11:58:10.000000000 -0700
+++ perl/ext/Hash/Util/FieldHash/FieldHash.xs 2006-07-11 01:06:26.000000000
-0700
@@ -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 @@
} 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 @@
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 @@
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 @@
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 @@
* 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 @@
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:
==== //depot/perl/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm#2 (text)
====
Index: perl/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm
--- perl/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm#1~28419~
2006-06-23 09:28:03.000000000 -0700
+++ perl/ext/Hash/Util/FieldHash/lib/Hash/Util/FieldHash.pm 2006-07-11
01:06:26.000000000 -0700
@@ -3,7 +3,6 @@
use 5.009004;
use strict;
use warnings;
-use Carp qw( croak);
use Scalar::Util qw( reftype);
require Exporter;
@@ -15,14 +14,13 @@
)],
);
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 @@
=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 @@
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 @@
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 @@
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 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 @@
=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,
==== //depot/perl/ext/Hash/Util/FieldHash/t/02_function.t#4 (text) ====
Index: perl/ext/Hash/Util/FieldHash/t/02_function.t
--- perl/ext/Hash/Util/FieldHash/t/02_function.t#3~28478~ 2006-07-04
11:58:10.000000000 -0700
+++ perl/ext/Hash/Util/FieldHash/t/02_function.t 2006-07-11
01:06:26.000000000 -0700
@@ -12,6 +12,7 @@
my $n_tests = 0;
use Hash::Util::FieldHash qw( :all);
+my $ob_reg = Hash::Util::FieldHash::_ob_reg;
#########################
@@ -26,7 +27,6 @@
BEGIN { $n_tests += 3 }
{
- my $ob_reg = \ %Hash::Util::FieldHash::ob_reg;
{
my $obj = {};
{
@@ -98,7 +98,7 @@
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 @@
}
# 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 @@
"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 @@
$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 @@
@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 @@
}
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");
}
{
==== //depot/perl/ext/Hash/Util/FieldHash/t/04_thread.t#3 (text) ====
Index: perl/ext/Hash/Util/FieldHash/t/04_thread.t
--- perl/ext/Hash/Util/FieldHash/t/04_thread.t#2~28432~ 2006-06-26
09:50:58.000000000 -0700
+++ perl/ext/Hash/Util/FieldHash/t/04_thread.t 2006-07-11 01:06:26.000000000
-0700
@@ -12,6 +12,7 @@
my $n_tests;
use Hash::Util::FieldHash qw( :all);
+my $ob_reg = Hash::Util::FieldHash::_ob_reg;
{
my $n_basic;
@@ -19,7 +20,6 @@
$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;
End of Patch.
