/* 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 {
} 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
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();
}
}
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 */
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
* 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 */
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:
use 5.009004;
use strict;
use warnings;
-use Carp qw( croak);
use Scalar::Util qw( reftype);
require Exporter;
)],
);
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);
}
=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
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;
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.
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';
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
=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,
my $n_tests = 0;
use Hash::Util::FieldHash qw( :all);
+my $ob_reg = Hash::Util::FieldHash::_ob_reg;
#########################
BEGIN { $n_tests += 3 }
{
- my $ob_reg = \ %Hash::Util::FieldHash::ob_reg;
{
my $obj = {};
{
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"
);
}
# 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;
"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 }
$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",
);
@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",
);
}
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");
}
{
my $n_tests;
use Hash::Util::FieldHash qw( :all);
+my $ob_reg = Hash::Util::FieldHash::_ob_reg;
{
my $n_basic;
$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;
projects / p5sagit/p5-mst-13.2.git / commitdiff