Front page | perl.perl5.porters |
Postings from July 2001
[PATCH for discussion] clamp, round #2
Thread Next
From:
Jeffrey Friedl
Date:
July 28, 2001 22:00
Subject:
[PATCH for discussion] clamp, round #2
Message ID:
200107290500.WAA02831@ventrue.corp.yahoo.com
Hiho,
Here's a patch which implements clamp, etc., via Readonly.pm, an XS module.
I spent a lot of time on the test suite (over 1,300 tests), but little
time on just how the Readonly.pm wrapper presents the functionality to
the user, since I'm sure others will have better ideas on how to do it.
The functionality is the main interest at this stage:
Scalar & Hash:
* can make readonly
* can remove readonlyness
* can inspect the readonlyness
(A readonly hash may not have keys added or deleted, or any value changed)
Clamping Hashes:
* can clamp a hash's keys:
May not add/delete keys -- a subset of a readonly hash
* can clamp access on non-approved keys:
May not reference non-approved keys. "Approved keys" are keys that
exist when a hash's access is clamped. You can then delete() them
if you don't really want them in your hash, but want to allow them.
The functionality is exported by Readonly.xs, and provided to the user via
Readonly.pm. Again, my implementation of the latter is just an example.
(Its docs are near the head of the patch, for easy perusal).
As it's too early at this stage for pod/* changes, none are included.
Jeffrey
--- bleedperl.orig/MANIFEST Tue Jul 17 02:28:33 2001
+++ bleedperl/MANIFEST Sat Jul 28 21:32:34 2001
@@ -460,6 +460,12 @@
ext/re/Makefile.PL re extension makefile writer
ext/re/re.pm re extension Perl module
ext/re/re.xs re extension external subroutines
+ext/Readonly/Makefile.PL Readonly extension makefile writer
+ext/Readonly/Readonly.pm Readonly extension module
+ext/Readonly/Readonly.xs Readonly extension subroutines
+ext/Readonly/t/common.pm Readonly extension test common routines
+ext/Readonly/t/hash.t Readonly extension tests for hashes
+ext/Readonly/t/scalar.t Readonly extension tests for scalars
ext/Safe/safe1.t See if Safe works
ext/Safe/safe2.t See if Safe works
ext/SDBM_File/Makefile.PL SDBM extension makefile writer
--- bleedperl.orig/ext/Readonly/Readonly.pm Sat Jul 28 21:32:36 2001
+++ bleedperl/ext/Readonly/Readonly.pm Sat Jul 28 16:48:27 2001
@@ -0,0 +1,398 @@
+package Readonly;
+$VERSION = 0.1;
+use strict;
+
+=head1 NAME
+
+Readonly - make things (only scalars and hashes for now) readonly, and more.
+
+These routines allow you to make scalars and hashes (and parts of hashes)
+readonly. They are advisory in that the readonlyness can be removed
+(and, in the case of global variables, hidden via C<local>).
+
+None of the routines that modify features of a variable can be applied
+to special variables.
+
+=head1 SYNOPSYS
+
+ Readonly::Set($x); ## Makes $x readonly.
+ $x = 1; ## *ERROR*
+
+ Readonly::Clear($x); ## Removes readonlyness from $x.
+ $x = 1; ## Now okay.
+
+ #########################################################
+
+ Readonly::Hash(%h); ## Makes the hash completely readonly.
+ $h{X} = 1; ## *ERROR*
+
+ Readonly::Clear($h{X}); ## Removes readonlyness from existing element.
+ $h{X} = 1; ## Now okay.
+
+ #########################################################
+
+ Clamp::Access(%h); ## Now illegal to access nonexistant element.
+ $val = $h{FOO}; ## *ERROR* if 'FOO' doesn't exist.
+ $h{FOO} = 1; ## Okay to add if only Access clamped.
+ $val = $h{FOO}; ## Now okay for sure, since element exists.
+
+ #########################################################
+
+ %x = (GOOD => 1,
+ OKAY => 1,
+ ALLOWED => 1);
+ Clamp::Access(%x);
+
+ delete($x{OKAY}); ## Doesn't exist but was there when clamped, so "approved"
+
+ $val = $x{FAIL}; ## *ERROR*; note that exists($x{FAIL}) is false
+ $val = $x{OKAY}; ## Good, even though exists($x{OKAY}) is false
+
+=cut
+
+
+require 5.6.0;
+require Exporter;
+use XSLoader ();
+
+our @ISA = 'Exporter';
+our @EXPORT = qw(CLAMP_NONE CLAMP_KEYS CLAMP_ACCESS CLAMP_ALL);
+
+XSLoader::load('Readonly');
+
+=head1 READONLY FOR SCALARS
+
+The following functions set, clear, and test the readonlyness of scalar
+values.
+
+=cut
+
+######################################################################
+
+=head2 Readonly::Set($scalar)
+
+The C<scalar> is made readonly.
+Returns true if it was already readonly, false otherwise.
+
+=cut
+
+sub Set(\$)
+{
+ my $ref = shift;
+ my $x = _setReadonlySV($$ref, 1);
+ return $x;
+}
+
+
+######################################################################
+
+=head2 Readonly::Clear($scalar)
+
+The C<scalar> is made non-readonly (i.e. writable).
+Returns true if it was readonly, false otherwise.
+
+=cut
+
+sub Clear(\$)
+{
+ my $ref = shift;
+ return _setReadonlySV($$ref, 0);
+}
+
+######################################################################
+
+=head2 Readonly::Check($scalar)
+
+Returns true if C<scalar> is readonly, false otherwise.
+
+=cut
+
+sub Check(\$)
+{
+ my $ref = shift;
+ return _getReadonlySV($$ref);
+}
+
+
+######################################################################
+
+=head1 READONLY FOR HASHES
+
+The following functions set, clear, and test the readonlyness of hashes
+values.
+
+A readonly hash has all its values readonly, as well as does not allow
+keys to be added or deleted.
+
+=cut
+
+######################################################################
+
+=head2 Readonly::Hash(%Hash)
+
+Sets the a hash to be readonly.
+Returns true if the hash was already completely readonly, false if
+any part of the has was not readonly.
+
+This causes each value of the hash to become readonly (which requires that
+this function walk the entire hash), as well as the hash being set such that
+keys may be neither added nor deleted.
+
+=cut
+
+sub Hash(\%;$)
+{
+ my $ref = shift;
+ my $ro = @_ ? shift(@_) : 1;
+
+ ##
+ ## Mark/clear the hash values as appropriate
+ ##
+ my $prev_writable = 0; ## set to be true if any hash value was writable
+ while (my ($key, $val) = each %$ref) {
+ if (not _setReadonlySV($ref->{$key}, $ro)) {
+ $prev_writable = 1;
+ }
+ }
+
+ ##
+ ## Set the new flags (noting the previous ones)
+ ##
+ my $prev_keys = _setReadonlyHV($ref, $ro);
+
+ return $prev_writable && $prev_keys;
+}
+
+######################################################################
+
+=head2 Readonly::ClearHash(%Hash)
+
+Sets the a hash to be writable. Returns true if the hash was completely
+readonly, false if any part of the has was not readonly.
+
+This causes each value of the hash to become writable (which requires that
+this function walk the entire hash), as well as the hash being set such that
+keys may be added and deleted.
+
+=cut
+
+sub ClearHash(\%;$)
+{
+ my $ref = shift;
+ return Hash(%$ref, 0);
+}
+
+######################################################################
+
+=head2 Readonly::CheckHash(%Hash)
+
+Returns true if the hash is completely readonly, false if any part of
+the hash is not readonly. This may have to walk the entire hash tree.
+
+=cut
+
+sub CheckHash(\%)
+{
+ my $ref = shift;
+
+ ## If the readonly bit is not set, the hash can't be readonly
+ if (not _getReadonlyHV($ref)) {
+ return 0;
+ }
+
+ ## If any value is not readonly, the hash isn't readonly.
+ while (my ($key, $val) = each %$ref) {
+ if (not _getReadonlySV($ref->{$key})) {
+ return 0;
+ }
+ }
+
+ ## gee, must be readonly
+ return 1;
+}
+
+######################################################################
+######################################################################
+
+
+=head1 CLAMPING HASHES
+
+Besides total readonlyness, there are two other restrictions that can
+be placed on a hash.
+
+A hash can have its keys clamped. This means that keys may not be added
+or deleted. This is a subset of making a hash readonly.
+
+Unrelated to either readonlyness or a hash's keys being clamped, you can
+clamp access on a hash to disallow access of "non-approved" keys. A key is
+"approved" if it exists at the time a hash's access is clamped and is not
+later deleted at a time its access isn't clamped.
+
+=cut
+
+sub CLAMP_NONE { 0x00 }
+sub CLAMP_KEYS { 0x01 }
+sub CLAMP_ACCESS { 0x02 }
+sub CLAMP_ALL { CLAMP_KEYS | CLAMP_ACCESS }
+
+
+=head2 Clamp::Set(%hash, FLAGS)
+
+Sets the clamped state of the named hash as per the C<FLAGS>, which are from:
+
+=over 5
+
+=item CLAMP_KEYS
+
+Sets the hash such that keys may not be added or deleted.
+
+=item CLAMP_ACCESS
+
+Sets the hash such that an attempt to access a "non-approved" key causes a
+runtime error. (Note that testing with C<exists()> is always allowed.)
+
+=item CLAMP_ALL
+
+Sets both C<CLAMP_KEYS> and C<CLAMP_ACCESS>
+
+=item CLAMP_NONE
+
+Neither C<CLAMP_KEYS> nor C<CLAMP_ACCESS>. Guaranteed to be a false value.
+
+=back
+
+The previous flags are returned.
+
+=cut
+
+sub Clamp::Set(\%;$)
+{
+ my $ref = shift;
+ my $flags = @_ ? shift(@_) : CLAMP_ALL;
+
+ my $prev_keys = _setReadonlyHV($ref, $flags & CLAMP_KEYS);
+ my $prev_access = _setClampHV ($ref, $flags & CLAMP_ACCESS);
+
+ return (($prev_keys ? CLAMP_KEYS : CLAMP_NONE)
+ |
+ ($prev_access ? CLAMP_ACCESS : CLAMP_NONE));
+}
+
+######################################################################
+
+=head2 Clamp::Check(%hash)
+
+Returns the C<CLAMP_KEYS> and C<CLAMP_ACCESS> flags as appropriate to
+the hash (like C<Clamp::Set>, but without modifying the hash's flags).
+
+=cut
+
+sub Clamp::Check(\%)
+{
+ my $ref = shift;
+ my $flags = @_ ? shift(@_) : CLAMP_ALL;
+
+ my $prev_keys = _getReadonlyHV($ref);
+ my $prev_access = _getClampHV ($ref);
+
+ return (($prev_keys ? CLAMP_KEYS : CLAMP_NONE)
+ |
+ ($prev_access ? CLAMP_ACCESS : CLAMP_NONE));
+}
+
+######################################################################
+
+=head2 Clamp::Keys(%hash)
+
+Sets the C<CLAMP_KEYS> state for the hash.
+Returns C<CLAMP_KEYS> if it was already set, C<CLAMP_NONE> otherwise.
+
+=cut
+
+sub Clamp::Keys(\%)
+{
+ my $ref = shift;
+ return _setReadonlyHV($ref, 1) ? CLAMP_KEYS : CLAMP_NONE;
+}
+
+######################################################################
+
+=head2 Clamp::ClearKeys(%hash)
+
+Clears the C<CLAMP_KEYS> state for the hash.
+Returns C<CLAMP_KEYS> if it was previously set, C<CLAMP_NONE> otherwise.
+
+=cut
+
+sub Clamp::ClearKeys(\%)
+{
+ my $ref = shift;
+ return _setReadonlyHV($ref, 0) ? CLAMP_KEYS : CLAMP_NONE;
+}
+
+######################################################################
+
+=head2 Clamp::CheckKeys(%hash)
+
+Checks the C<CLAMP_KEYS> state for the hash.
+Returns C<CLAMP_KEYS> if is set, C<CLAMP_NONE> otherwise.
+
+=cut
+
+sub Clamp::CheckKeys(\%)
+{
+ my $ref = shift;
+ return _getReadonlyHV($ref) ? CLAMP_KEYS : CLAMP_NONE;
+}
+
+######################################################################
+
+=head2 Clamp::Access(%hash)
+
+Sets the C<CLAMP_ACCESS> state for the hash.
+Returns C<CLAMP_ACCESS> if it was already set, C<CLAMP_NONE> otherwise.
+
+=cut
+
+sub Clamp::Access(\%)
+{
+ my $ref = shift;
+ return _setClampHV($ref, 1) ? CLAMP_ACCESS : CLAMP_NONE;
+}
+
+######################################################################
+
+=head2 Clamp::ClearAccess(%hash)
+
+Clears the C<CLAMP_ACCESS> state for the hash.
+Returns C<CLAMP_ACCESS> if it was previously set, C<CLAMP_NONE> otherwise.
+
+=cut
+
+sub Clamp::ClearAccess(\%)
+{
+ my $ref = shift;
+ return _setClampHV($ref, 0) ? CLAMP_ACCESS : CLAMP_NONE;
+}
+
+######################################################################
+
+=head2 Clamp::CheckAccess(%hash)
+
+Checks the C<CLAMP_ACCESS> state for the hash.
+Returns C<CLAMP_ACCESS> if is set, C<CLAMP_NONE> otherwise.
+
+=cut
+
+sub Clamp::CheckAccess(\%)
+{
+ my $ref = shift;
+ return _getClampHV($ref) ? CLAMP_ACCESS : CLAMP_NONE;
+}
+
+######################################################################
+######################################################################
+
+
+1;
+__END__
--- bleedperl.orig/ext/Readonly/Readonly.xs Sat Jul 28 21:32:36 2001
+++ bleedperl/ext/Readonly/Readonly.xs Fri Jul 27 10:55:19 2001
@@ -0,0 +1,146 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/*
+ * Provides the basic ability to set/clear the SvREADONLY bit of scalars,
+ * and the SvREADONLY/HvCLAMPEDACCESS_on bits of hashes.
+ * (Arrays are left for the future)
+ *
+ * Also provides the ability to query the bits.
+ *
+ * Can not modify the bits for magic scalars/hashes, as I'm not yet sure
+ * what that would really mean.
+ *
+ * Jeffrey Friedl
+ * jfriedl@oreilly.com
+ * July 2001
+ *
+ */
+
+MODULE = Readonly PACKAGE = Readonly
+
+##
+## _setReadonlySV($SCALAR, $FLAG)
+##
+## If FLAG is true, sets the SvREADONLY bit for SCALAR.
+## Otherwise, clears it.
+##
+## Returns true if the bit had been set; false otherwise.
+##
+unsigned int
+_setReadonlySV( IN_OUT SV *sv, IN unsigned int flag)
+ PROTOTYPE: $$
+ CODE:
+ {
+ if (SvMAGICAL(sv))
+ croak("Can't modify readonlyness of special variable");
+
+ RETVAL = SvREADONLY(sv) ? 1 : 0;
+ if (flag)
+ SvREADONLY_on(sv);
+ else
+ SvREADONLY_off(sv);
+ }
+ OUTPUT:
+ RETVAL
+
+##
+## _getReadonlySV($SCALAR)
+##
+## Returns true if the SvREADONLY bit is set for the SCALAR;
+## false otherwise
+##
+unsigned int
+_getReadonlySV( IN_OUT SV *sv)
+ PROTOTYPE: $
+ CODE:
+ {
+ RETVAL = SvREADONLY(sv) ? 1 : 0;
+ }
+ OUTPUT:
+ RETVAL
+
+
+##
+## _setReadonlyHV(%HASH, $FLAG)
+##
+## If FLAG is true, sets the SvREADONLY bit for HASH.
+## Otherwise, clears it.
+##
+## Returns true if the bit had been set; false otherwise.
+##
+unsigned int
+_setReadonlyHV( IN_OUT HV *hv, IN unsigned int flag)
+ PROTOTYPE: \%$
+ CODE:
+ {
+ if (SvMAGICAL(hv))
+ croak("Can't modify readonlyness of special variable");
+
+ RETVAL = SvREADONLY(hv) ? 1 : 0;
+ if (flag)
+ SvREADONLY_on(hv);
+ else
+ SvREADONLY_off(hv);
+ }
+ OUTPUT:
+ RETVAL
+
+##
+## _getReadonlyHV($SCALAR)
+##
+## Returns true if the SvREADONLY bit is set for the HASH;
+## false otherwise
+##
+unsigned int
+_getReadonlyHV( IN_OUT HV *hv)
+ PROTOTYPE: \%
+ CODE:
+ {
+ RETVAL = SvREADONLY(hv) ? 1 : 0;
+ }
+ OUTPUT:
+ RETVAL
+
+
+##
+## _setClampHV(%HASH, $FLAG)
+##
+## If FLAG is true, sets the SvCLAMPEDACCESS bit for HASH.
+## Otherwise, clears it.
+##
+## Returns true if the bit had been set; false otherwise.
+##
+unsigned int
+_setClampHV( IN_OUT HV *hv, IN unsigned int flag)
+ PROTOTYPE: \%$
+ CODE:
+ {
+ if (SvMAGICAL(hv))
+ croak("Can't clamp special variable");
+
+ RETVAL = HvCLAMPEDACCESS(hv) ? 1 : 0;
+ if (flag)
+ HvCLAMPEDACCESS_on(hv);
+ else
+ HvCLAMPEDACCESS_off(hv);
+ }
+ OUTPUT:
+ RETVAL
+
+##
+## _getClampHV($SCALAR)
+##
+## Returns true if the SvCLAMPEDACCESS bit is set for the HASH;
+## false otherwise
+##
+unsigned int
+_getClampHV( IN_OUT HV *hv)
+ PROTOTYPE: \%
+ CODE:
+ {
+ RETVAL = HvCLAMPEDACCESS(hv) ? 1 : 0;
+ }
+ OUTPUT:
+ RETVAL
--- bleedperl.orig/ext/Readonly/Makefile.PL Sat Jul 28 21:32:36 2001
+++ bleedperl/ext/Readonly/Makefile.PL Thu Jul 26 00:47:26 2001
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => "Readonly",
+ VERSION_FROM => 'Readonly.pm',
+ 'dist' => {
+ COMPRESS => 'gzip -9f',
+ SUFFIX => 'gz',
+ DIST_DEFAULT => 'all tardist',
+ },
+ MAN3PODS => {},
+);
--- bleedperl.orig/hv.h Sun Jun 17 19:01:05 2001
+++ bleedperl/hv.h Sat Jul 28 21:14:52 2001
@@ -31,7 +31,7 @@
char * xhv_array; /* pointer to malloced string */
STRLEN xhv_fill; /* how full xhv_array currently is */
STRLEN xhv_max; /* subscript of last element of xhv_array */
- IV xhv_keys; /* how many elements in the array */
+ IV xhv_realkeys; /* elements in the array (excl placeholders) */
NV xnv_nv; /* numeric value, if any */
MAGIC* xmg_magic; /* magic for scalar array */
HV* xmg_stash; /* class package */
@@ -40,6 +40,7 @@
HE *xhv_eiter; /* current entry of iterator */
PMOP *xhv_pmroot; /* list of pm's for this package */
char *xhv_name; /* name, if a symbol table */
+ IV xhv_keys; /* elements in the array (incl placeholders) */
};
/* hash a key */
@@ -127,10 +128,15 @@
#define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill
#define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max
#define HvKEYS(hv) ((XPVHV*) SvANY(hv))->xhv_keys
+#define HvREALKEYS(hv) ((XPVHV*) SvANY(hv))->xhv_realkeys
#define HvRITER(hv) ((XPVHV*) SvANY(hv))->xhv_riter
#define HvEITER(hv) ((XPVHV*) SvANY(hv))->xhv_eiter
#define HvPMROOT(hv) ((XPVHV*) SvANY(hv))->xhv_pmroot
#define HvNAME(hv) ((XPVHV*) SvANY(hv))->xhv_name
+
+#define HvCLAMPEDACCESS(hv) (SvFLAGS(hv) & SVh_CLAMP_ACCESS)
+#define HvCLAMPEDACCESS_on(hv) (SvFLAGS(hv) |= SVh_CLAMP_ACCESS)
+#define HvCLAMPEDACCESS_off(hv) (SvFLAGS(hv) &= ~SVh_CLAMP_ACCESS)
#define HvSHAREKEYS(hv) (SvFLAGS(hv) & SVphv_SHAREKEYS)
#define HvSHAREKEYS_on(hv) (SvFLAGS(hv) |= SVphv_SHAREKEYS)
--- bleedperl.orig/intrpvar.h Wed Jul 11 21:51:46 2001
+++ bleedperl/intrpvar.h Sat Jul 28 19:05:06 2001
@@ -283,6 +283,9 @@
PERLVAR(Isv_no, SV)
PERLVAR(Isv_yes, SV)
+/* "approved" (but not exists()) keys in access-clamped hashes */
+PERLVAR(Isv_placehold, SV)
+
#ifdef CSH
PERLVARI(Icshname, char *, CSH)
PERLVAR(Icshlen, I32)
--- bleedperl.orig/sv.h Sun Jul 8 17:03:52 2001
+++ bleedperl/sv.h Thu Jul 26 11:10:06 2001
@@ -234,6 +234,8 @@
#define SVprv_WEAKREF 0x80000000 /* Weak reference */
+#define SVh_CLAMP_ACCESS 0x08000000 /* hash access has been clamped */
+
struct xrv {
SV * xrv_rv; /* pointer to another SV */
};
@@ -1204,7 +1206,7 @@
#define SvPEEK(sv) ""
#endif
-#define SvIMMORTAL(sv) ((sv)==&PL_sv_undef || (sv)==&PL_sv_yes || (sv)==&PL_sv_no)
+#define SvIMMORTAL(sv) ((sv)==&PL_sv_undef || (sv)==&PL_sv_yes || (sv)==&PL_sv_no || (sv)==&PL_sv_placehold)
#define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
--- bleedperl.orig/hv.c Thu Jul 12 21:39:22 2001
+++ bleedperl/hv.c Sat Jul 28 21:15:16 2001
@@ -222,6 +222,14 @@
continue;
if (key != keysave)
Safefree(key);
+
+ /* if we find the entry but it's a placeholder, it's as if not found */
+ if (HeVAL(entry) == &PL_sv_placehold)
+ break;
+
+ if (lval && SvREADONLY(HeVAL(entry)) && !SvMAGICAL(HeVAL(entry)))
+ Perl_warner(aTHX_ WARN_INTERNAL, "Can't modify readonly value for key {%s}", key);
+
return &HeVAL(entry);
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
@@ -237,6 +245,29 @@
}
}
#endif
+
+ /*
+ * If we get here and lval is true, we're trying to add a new key.
+ */
+ if (lval)
+ {
+ if (SvREADONLY(hv))
+ Perl_croak(aTHX_ "Can't add a new key {%s} to readonly/clamped hash", key);
+ /* if not readonly, allowed to add a new key even if clamped */
+ }
+ else if (!entry && HvCLAMPEDACCESS(hv))
+ {
+ /*
+ * If we get here, we're trying to access (not add) a new key.
+ * If entry has something, it's because we bailed above due to
+ * &PL_sv_placehold, and in that case it's a "pre-approved" key
+ * that we can access. But if not and we get here, it's an attempt
+ * to access a brand new key, and that's not allowed if clamped.
+ */
+ Perl_croak(aTHX_ "Can't access nonexistant key {%s} of readonly/clamped hash", key);
+ }
+
+
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
if (key != keysave) { /* must be is_utf8 == 0 */
@@ -282,6 +313,7 @@
bool is_utf8;
char *keysave;
+
if (!hv)
return 0;
@@ -352,6 +384,28 @@
continue;
if (key != keysave)
Safefree(key);
+
+
+ /* if we find the entry but it's a placeholder, it's as if not found */
+ if (HeVAL(entry) == &PL_sv_placehold)
+ break;
+
+#if 0
+ /*
+ * I want to have this here so that access to a readonly key gives
+ * a message that tells which key is being accessed, but since it
+ * seems that the when executing
+ * \$hash{KEY}
+ * this function is called to get the reference, but its done with
+ * a true 'lval', so it makes it appear that it's an assignment.
+ * (Probably because the key must autovivify)
+ *
+ * Bummer.
+ */
+ if (lval && SvREADONLY(HeVAL(entry)) && !SvMAGICAL(HeVAL(entry)))
+ Perl_croak(aTHX_ "Can't modify readonly value for key {%s}", key);
+#endif
+
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
@@ -365,6 +419,28 @@
}
}
#endif
+
+ /*
+ * If we get here and lval is true, we're trying to add a new key.
+ */
+ if (lval)
+ {
+ if (SvREADONLY(hv))
+ Perl_croak(aTHX_ "Can't add a new key {%s} to readonly/clamped hash", key);
+ /* if not readonly, allowed to add a new key even if clamped */
+ }
+ else if (!entry && HvCLAMPEDACCESS(hv))
+ {
+ /*
+ * If we get here, we're trying to access (not add) a new key.
+ * If entry has something, it's because we bailed above due to
+ * &PL_sv_placehold, and in that case it's a "pre-approved" key
+ * that we can access. But if not and we get here, it's an attempt
+ * to access a brand new key, and that's not allowed if clamped.
+ */
+ Perl_croak(aTHX_ "Can't access nonexistant key {%s} of readonly/clamped hash", key);
+ }
+
if (key != keysave)
Safefree(key);
if (lval) { /* gonna assign to this, so it better be there */
@@ -475,13 +551,29 @@
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
- SvREFCNT_dec(HeVAL(entry));
+
+ if (HeVAL(entry) == &PL_sv_placehold) {
+ /*
+ * We'll be using this same slot, so the number of allocated
+ * keys doesn't go up, but the number of user-visible keys does.
+ */
+ xhv->xhv_realkeys++; /* HvREALKEYS(hv)++ */
+ } else {
+ if (SvREADONLY(HeVAL(entry)) && !SvMAGICAL(HeVAL(entry)))
+ Perl_croak(aTHX_ "Can't modify readonly value for key {%s}", key);
+
+ SvREFCNT_dec(HeVAL(entry));
+ }
+
HeVAL(entry) = val;
if (key != keysave)
Safefree(key);
return &HeVAL(entry);
}
+ if (!val && HvCLAMPEDACCESS(hv))
+ Perl_croak(aTHX_ "Can't access nonexistant key {%s} of readonly/clamped hash", key);
+
entry = new_HE();
if (HvSHAREKEYS(hv))
HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
@@ -494,6 +586,7 @@
*oentry = entry;
xhv->xhv_keys++; /* HvKEYS(hv)++ */
+ xhv->xhv_realkeys++; /* HvREALKEYS(hv)-- */
if (i) { /* initial entry? */
xhv->xhv_fill++; /* HvFILL(hv)++ */
if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
@@ -563,6 +656,7 @@
}
keysave = key = SvPV(keysv, klen);
+
is_utf8 = (SvUTF8(keysv) != 0);
if (is_utf8)
@@ -589,13 +683,29 @@
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
- SvREFCNT_dec(HeVAL(entry));
+
+ if (HeVAL(entry) == &PL_sv_placehold) {
+ /*
+ * We'll be using this same slot, so the number of allocated
+ * keys doesn't go up, but the number of user-visible keys does.
+ */
+ xhv->xhv_realkeys++; /* HvREALKEYS(hv)++ */
+ } else {
+ if (SvREADONLY(HeVAL(entry)) && !SvMAGICAL(HeVAL(entry)))
+ Perl_croak(aTHX_ "Can't modify readonly value for key {%s}", key);
+
+ SvREFCNT_dec(HeVAL(entry));
+ }
+
HeVAL(entry) = val;
if (key != keysave)
Safefree(key);
return entry;
}
+ if (!val && HvCLAMPEDACCESS(hv))
+ Perl_croak(aTHX_ "Can't access nonexistant key {%s} of readonly/clamped hash", key);
+
entry = new_HE();
if (HvSHAREKEYS(hv))
HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
@@ -608,6 +718,7 @@
*oentry = entry;
xhv->xhv_keys++; /* HvKEYS(hv)++ */
+ xhv->xhv_realkeys++; /* HvREALKEYS(hv)-- */
if (i) { /* initial entry? */
xhv->xhv_fill++; /* HvFILL(hv)++ */
if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
@@ -675,6 +786,9 @@
if (!xhv->xhv_array /* !HvARRAY(hv) */)
return Nullsv;
+ if (SvREADONLY(hv))
+ Perl_croak(aTHX_ "Can't delete key {%s} of readonly/clamped", key);
+
if (is_utf8) {
STRLEN tmplen = klen;
/* See the note in hv_fetch(). --jhi */
@@ -699,20 +813,40 @@
continue;
if (key != keysave)
Safefree(key);
- *oentry = HeNEXT(entry);
+
+ /* found the key to delete */
+ if (!HvCLAMPEDACCESS(hv))
+ *oentry = HeNEXT(entry);
+
if (i && !*oentry)
xhv->xhv_fill--; /* HvFILL(hv)-- */
if (flags & G_DISCARD)
sv = Nullsv;
else {
sv = sv_2mortal(HeVAL(entry));
- HeVAL(entry) = &PL_sv_undef;
+ if (!HvCLAMPEDACCESS(hv))
+ HeVAL(entry) = &PL_sv_undef;
+ }
+
+ /*
+ * If access is clamped, rather than really deleting the entry,
+ * put a placeholder there. This marks the key as being "approved",
+ * so we can still access via not-really-existing key without
+ * raising an error.
+ */
+ if (HvCLAMPEDACCESS(hv)) {
+ HeVAL(entry) = &PL_sv_placehold;
+ /* We'll be saving this same slot, so the number of allocated keys
+ * doesn't go down, but the number of user-visible keys does. */
+ xhv->xhv_realkeys--; /* HvREALKEYS(hv)-- */
+ } else {
+ if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ xhv->xhv_realkeys--; /* HvREALKEYS(hv)-- */
}
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
return sv;
}
if (key != keysave)
@@ -744,6 +878,7 @@
bool is_utf8;
char *keysave;
+
if (!hv)
return Nullsv;
if (SvRMAGICAL(hv)) {
@@ -779,6 +914,9 @@
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
+ if (SvREADONLY(hv))
+ Perl_croak(aTHX_ "Can't delete key {%s} of readonly/clamped", key);
+
if (is_utf8)
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
@@ -800,20 +938,40 @@
continue;
if (key != keysave)
Safefree(key);
- *oentry = HeNEXT(entry);
+
+ /* found the key to delete */
+ if (!HvCLAMPEDACCESS(hv))
+ *oentry = HeNEXT(entry);
+
if (i && !*oentry)
xhv->xhv_fill--; /* HvFILL(hv)-- */
- if (flags & G_DISCARD)
+ if (flags & G_DISCARD) {
sv = Nullsv;
- else {
+ } else {
sv = sv_2mortal(HeVAL(entry));
- HeVAL(entry) = &PL_sv_undef;
+ if (!HvCLAMPEDACCESS(hv))
+ HeVAL(entry) = &PL_sv_undef;
+ }
+
+ /*
+ * If access is clamped, rather than really deleting the entry,
+ * put a placeholder there. This marks the key as being "approved",
+ * so we can still access via not-really-existing key without
+ * raising an error.
+ */
+ if (HvCLAMPEDACCESS(hv)) {
+ HeVAL(entry) = &PL_sv_placehold;
+ /* We'll be saving this same slot, so the number of allocated keys
+ * doesn't go down, but the number of user-visible keys does. */
+ xhv->xhv_realkeys--; /* HvREALKEYS(hv)-- */
+ } else {
+ if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ xhv->xhv_realkeys--; /* HvREALKEYS(hv)-- */
}
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
return sv;
}
if (key != keysave)
@@ -895,7 +1053,16 @@
continue;
if (key != keysave)
Safefree(key);
- return TRUE;
+
+ /*
+ * If we find the key, but the value is a placeholder, we return
+ * false (but leave the placeholder so we can access the key even
+ * with access clamped).
+ */
+ if (HeVAL(entry) == &PL_sv_placehold)
+ return FALSE;
+ else
+ return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
@@ -988,7 +1155,15 @@
continue;
if (key != keysave)
Safefree(key);
- return TRUE;
+ /*
+ * If we find the key, but the value is a placeholder, we return
+ * false (but leave the placeholder so we can access the key even
+ * with access clamped).
+ */
+ if (HeVAL(entry) == &PL_sv_placehold)
+ return FALSE;
+ else
+ return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
@@ -1272,8 +1447,9 @@
return;
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
- xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
- xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
+ xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
+ xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
+ xhv->xhv_realkeys = 0; /* HvREALKEYS(hv) = 0 */
if (xhv->xhv_array /* HvARRAY(hv) */)
(void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
(xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
@@ -1340,6 +1516,7 @@
xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
+ xhv->xhv_realkeys = 0; /* HvREALKEYS(hv) = 0 */
if (SvRMAGICAL(hv))
mg_clear((SV*)hv);
@@ -1349,7 +1526,7 @@
=for apidoc hv_iterinit
Prepares a starting point to traverse a hash table. Returns the number of
-keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
+keys in the hash (i.e. the same as C<HvREALKEYS(tb)>). The return value is
currently only meaningful for hashes without tie magic.
NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
@@ -1376,7 +1553,7 @@
xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
/* used to be xhv->xhv_fill before 5.004_65 */
- return xhv->xhv_keys; /* HvKEYS(hv) */
+ return xhv->xhv_realkeys; /* HvREALKEYS(hv) */
}
/*
@@ -1440,8 +1617,19 @@
Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
char);
- if (entry)
+ if (entry) {
entry = HeNEXT(entry);
+
+ /*
+ * Skip past any placeholders -- don't want to include them in
+ * any iteration.
+ */
+ while (entry && HeVAL(entry) == &PL_sv_placehold) {
+ entry = HeNEXT(entry);
+ }
+ }
+
+
while (!entry) {
xhv->xhv_riter++; /* HvRITER(hv)++ */
if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
@@ -1450,6 +1638,10 @@
}
/* entry = (HvARRAY(hv))[HvRITER(hv)]; */
entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
+
+ /* if we have an entry, but it's a placeholder, we don't have squat */
+ while (entry && HeVAL(entry) == &PL_sv_placehold)
+ entry = 0;
}
if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
@@ -1618,6 +1810,7 @@
Safefree(HeKEY_hek(entry));
del_HE(entry);
xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ xhv->xhv_realkeys--; /* HvREALKEYS(hv)-- */
}
break;
}
@@ -1680,6 +1873,7 @@
HeNEXT(entry) = *oentry;
*oentry = entry;
xhv->xhv_keys++; /* HvKEYS(hv)++ */
+ xhv->xhv_realkeys++; /* HvREALKEYS(hv)++ */
if (i) { /* initial entry? */
xhv->xhv_fill++; /* HvFILL(hv)++ */
if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
--- bleedperl.orig/doop.c Wed May 30 17:17:22 2001
+++ bleedperl/doop.c Sat Jul 28 20:11:52 2001
@@ -1308,7 +1308,7 @@
}
if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied))
- i = HvKEYS(keys);
+ i = HvREALKEYS(keys);
else {
i = 0;
/*SUPPRESS 560*/
@@ -1318,7 +1318,7 @@
RETURN;
}
- EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
+ EXTEND(SP, HvREALKEYS(keys) * (dokeys + dovalues));
PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
while ((entry = hv_iternext(keys))) {
--- bleedperl.orig/perl.c Wed Jul 11 23:02:05 2001
+++ bleedperl/perl.c Thu Jul 26 23:00:26 2001
@@ -224,6 +224,9 @@
SvREADONLY_on(&PL_sv_undef);
SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+ SvREADONLY_on(&PL_sv_placehold);
+ SvREFCNT(&PL_sv_placehold) = (~(U32)0)/2;
+
sv_setpv(&PL_sv_no,PL_No);
SvNV(&PL_sv_no);
SvREADONLY_on(&PL_sv_no);
--- bleedperl.orig/scope.c Sat May 26 07:17:09 2001
+++ bleedperl/scope.c Sat Jul 28 10:05:46 2001
@@ -177,7 +177,7 @@
while (PL_tmps_ix > myfloor) { /* clean up after last statement */
SV* sv = PL_tmps_stack[PL_tmps_ix];
PL_tmps_stack[PL_tmps_ix--] = Nullsv;
- if (sv) {
+ if (sv && sv != &PL_sv_placehold) {
SvTEMP_off(sv);
SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */
}
@@ -831,8 +831,18 @@
sv = *(SV**)ptr;
/* Can clear pad variable in place? */
if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
+ /*
+ * if a my variable that was made readonly is going out of
+ * scope, we want to remove the readonlyness so that it can
+ * go out of scope quietly
+ */
+ if (SvPADMY(sv))
+ SvREADONLY_off(sv);
+
if (SvTHINKFIRST(sv))
+ {
sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
+ }
if (SvMAGICAL(sv))
mg_free(sv);
--- bleedperl.orig/mg.c Sat Jun 30 15:04:54 2001
+++ bleedperl/mg.c Sat Jul 28 21:15:01 2001
@@ -1152,7 +1152,7 @@
if (hv) {
(void) hv_iterinit(hv);
if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
- i = HvKEYS(hv);
+ i = HvREALKEYS(hv);
else {
while (hv_iternext(hv))
i++;
--- bleedperl.orig/sv.c Mon Jul 16 07:57:30 2001
+++ bleedperl/sv.c Sat Jul 28 19:36:10 2001
@@ -1418,6 +1418,7 @@
HvFILL(sv) = 0;
HvMAX(sv) = 0;
HvKEYS(sv) = 0;
+ HvREALKEYS(sv) = 0;
SvNVX(sv) = 0.0;
SvMAGIC(sv) = magic;
SvSTASH(sv) = stash;
--- bleedperl.orig/Porting/config.sh Fri Jul 13 07:15:16 2001
+++ bleedperl/Porting/config.sh Fri Jul 27 12:15:47 2001
@@ -430,7 +430,7 @@
dlsrc='dl_dlopen.xs'
doublesize='8'
drand01='drand48()'
-dynamic_ext='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re'
+dynamic_ext='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via Readonly SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re'
eagain='EAGAIN'
ebcdic='undef'
echo='echo'
@@ -439,7 +439,7 @@
eunicefix=':'
exe_ext=''
expr='expr'
-extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re Errno'
+extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via Readonly SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re Errno'
fflushNULL='define'
fflushall='undef'
find=''
@@ -581,7 +581,7 @@
ivdformat='"ld"'
ivsize='8'
ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re'
+known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode Readonly POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re'
ksh=''
ld='ld'
lddlflags='-shared -expect_unresolved "*" -msym -std -s'
--- bleedperl.orig/t/lib/1_compile.t Thu Jul 12 21:39:22 2001
+++ bleedperl/t/lib/1_compile.t Fri Jul 27 12:14:15 2001
@@ -224,6 +224,7 @@
Pod::Find
Pod::Text
Pod::Usage
+Readonly
SDBM_File
Safe
Scalar::Util
--- bleedperl.orig/ext/Readonly/t/hash.t Sat Jul 28 21:32:36 2001
+++ bleedperl/ext/Readonly/t/hash.t Sat Jul 28 20:21:56 2001
@@ -0,0 +1,1706 @@
+#!./perl -w
+
+##
+## Basic test suite for Readonly and clamped hashes.
+##
+## Use with -v option to get info on failed tests.
+##
+## Use with -vv option to get info on all tests.
+##
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw[../lib ../../../lib .];
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bReadonly\b/) {
+ print "1..0 # Skip: was not built\n";
+ exit 0;
+ }
+
+ ## put into @INC the directory in which this file lies
+ my $thisdir = __FILE__;
+ $thisdir =~ s{/[^/]+$}{};
+ push @INC, $thisdir
+}
+
+use Readonly;
+use common;
+use strict;
+
+
+our $verbose = 0;
+
+##
+## Check args (-v shows failed test info, -vv shows all test info)
+##
+while (@ARGV and $ARGV[0] =~ m/^-/)
+{
+ my $arg = shift;
+ if ($arg =~ m/^-(v+)$/) {
+ $verbose += length $1;
+ }
+ else
+ {
+ die << "--DIE--";
+$0: bad arg [$arg]
+Usage: $0 [-v|-vv]
+--DIE--
+ }
+}
+
+## set up some random data for the tests...
+my $A = 92;
+my $B = 93;
+my $C = 94;
+my $D = 95;
+my $M = 106;
+my $N = 107;
+my $TMP = 96;
+my $a;
+
+sub Flatten(@)
+{
+ return join('|', sort map {
+ defined($_) ? $_ : "<U>"
+ } @_);
+}
+
+## Given a hash, return a string that represents its keys/values
+sub DumpHash(\%)
+{
+ my $ref = shift;
+ my @out;
+ for my $key (sort keys %$ref)
+ {
+ my $val = defined($ref->{$key}) ? $ref->{$key} : "<U>";
+ push @out, $key, $val;
+ }
+ return join('', '[', @out, ']');
+}
+
+
+
+##
+## Here are the main overall settings for running the tests (the suite of
+## tests will be run for each setting.
+##
+## The 'Test' indicates which key of the @Tests we expect to get back for
+## the setting. 'Prep' says how to set up the hash %x for that setting.
+##
+my @Setting =
+(
+ {
+ Test => 'Norm',
+ Prep => q{ # normal hash }, ## normal unmolested hashes
+ },
+ {
+ Test => 'RO',
+ Prep => q{ Readonly::Hash(%x) },
+ },
+ {
+ Test => 'Norm',
+ Prep => q{ Readonly::ClearHash(%x) },
+ },
+ {
+ Test => 'RO',
+ Prep => q{ Readonly::Hash(%x); Readonly::Hash(%x) },
+ },
+ {
+ Test => 'Norm',
+ Prep => q{ Readonly::Hash(%x); Readonly::ClearHash(%x) },
+ },
+ {
+ Test => 'Access',
+ Prep => q{ Clamp::Access(%x) },
+ },
+ {
+ Test => 'Norm',
+ Prep => q{ Clamp::Access(%x); Clamp::ClearAccess(%x) },
+ },
+ {
+ Test => 'Keys',
+ Prep => q{ Clamp::Keys(%x) },
+ },
+ {
+ Test => 'Norm',
+ Prep => q{ Clamp::Keys(%x); Clamp::ClearKeys(%x) },
+ },
+ {
+ Test => 'Both',
+ Prep => q{ Clamp::Set(%x, CLAMP_ALL) },
+ },
+ {
+ Test => 'Norm',
+ Prep => q{ Clamp::Set(%x, CLAMP_ALL); Clamp::Set(%x, CLAMP_NONE) },
+ },
+);
+
+##
+## Here are the tests. They are run in order (starting fresh for each
+## situation).
+##
+## 'Name' is just a descriptive name.
+## 'Code' is the actual test
+## 'Norm' is the result we expect for unmolested hashes.
+## 'RO' is the result we expect for readonly hashes.
+## 'Access' is the result we expect for hashes with access clamped.
+## 'Keys' is the result we expect for hashes with keys clamped.
+## 'Both' is the result we expect for hashes with both clamped.
+##
+my @Tests1 =
+(
+ ## 1
+ {
+ Name => 'exists() for element that does exist',
+ Code => q{ exists($x{A}) },
+ Norm => Success(1),
+ RO => Success(1),
+ Access => Success(1),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+ ## 2
+ {
+ Name => 'defined() for element that does exist',
+ Code => q{ defined($x{A}) },
+ Norm => Success(1),
+ RO => Success(1),
+ Access => Success(1),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+ ## 3
+ {
+ Name => 'exists() for element that does not exist',
+ Code => q{ exists($x{Z1}) },
+ Norm => Success(''),
+ RO => Success(''),
+ Access => Success(''),
+ Keys => Success(''),
+ Both => Success(''),
+ },
+
+ ## 4
+ {
+ Name => 'defined() for element that does not exist',
+ Code => q{ defined($x{Z2}) },
+ Norm => Success(''),
+ RO => Success(''),
+ Access => NoAccess(),
+ Keys => Success(''),
+ Both => NoAccess(),
+ },
+
+ ## 5
+ {
+ Name => 'access of key that does exist',
+ Code => q{ $a = $x{A} },
+ Norm => Success($A),
+ RO => Success($A),
+ Access => Success($A),
+ Keys => Success($A),
+ Both => Success($A),
+ },
+
+ ## 6
+ {
+ Name => 'access of key that does not exist',
+ Code => q{ $a = $x{Z3} },
+ Norm => Success(undef),
+ RO => Success(undef),
+ Access => NoAccess(),
+ Keys => Success(undef),
+ Both => NoAccess(),
+ },
+
+ ## 7
+ {
+ Name => 'update with same value',
+ Code => q{ $x{A} = $A },
+ Norm => Success($A),
+ RO => NoMod(), #NoModKey(),
+ Access => Success($A),
+ Keys => Success($A),
+ Both => Success($A),
+ },
+
+ ## 8
+ {
+ Name => 'update with different value',
+ Code => q{ $x{A} = $TMP },
+ Norm => Success($TMP),
+ RO => NoMod(), #NoModKey(),
+ Access => Success($TMP),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ## 9
+ {
+ Name => 'add key',
+ Code => q{ $x{D} = $D },
+ Norm => Success($D),
+ RO => NoAdd(),
+ Access => Success($D),
+ Keys => NoAdd(),
+ Both => NoAdd(),
+ },
+
+ ## 10
+ {
+ Name => 'delete key that exists',
+ Code => q{ delete $x{B} },
+ Norm => Success($B),
+ RO => NoDelete(),
+ Access => Success($B),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ## 11
+ {
+ Name => 'delete key that was just deleted',
+ Code => q{ delete $x{B} },
+ Norm => Success(undef),
+ RO => NoDelete(),
+ Access => Success(undef),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ## 12
+ {
+ Name => 'exists() of key just deleted',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## because wasn't just deleted
+ Access => Success(''),
+ Keys => Success(1), ## because wasn't just deleted
+ Both => Success(1), ## because wasn't just deleted
+ },
+
+ ## 13
+ {
+ Name => 'defined() of key just deleted',
+ Code => q{ defined($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## because wasn't just deleted
+ Access => Success(''),
+ Keys => Success(1), ## because wasn't just deleted
+ Both => Success(1), ## because wasn't just deleted
+ },
+
+ ## 14
+ {
+ Name => 'delete key that does not exist',
+ Code => q{ delete $x{B} },
+ Norm => Success(undef),
+ RO => NoDelete(),
+ Access => Success(undef),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ## 15
+ {
+ Name => 'exists() of just-deleted non-existant key',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## because wasn't just deleted
+ Access => Success(''),
+ Keys => Success(1), ## because wasn't just deleted
+ Both => Success(1), ## because wasn't just deleted
+ },
+
+ ## 16
+ {
+ Name => 'defined() of just-deleted non-existant key',
+ Code => q{ defined($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## because wasn't just deleted
+ Access => Success(''),
+ Keys => Success(1), ## because wasn't just deleted
+ Both => Success(1), ## because wasn't just deleted
+ },
+
+ ## 17
+ {
+ Name => 'delete key that never existed',
+ Code => q{ delete $x{Z4} },
+ Norm => Success(undef),
+ RO => NoDelete(),
+ Access => Success(undef),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ## 18
+ {
+ Name => 'exists() of just-deleted never-existant key',
+ Code => q{ exists($x{Z4}) },
+ Norm => Success(''),
+ RO => Success(''),
+ Access => Success(''),
+ Keys => Success(''),
+ Both => Success(''),
+ },
+
+ ## 19
+ {
+ Name => 'defined() of just-deleted never-existant key',
+ Code => q{ defined($x{Z4}) },
+ Norm => Success(''),
+ RO => Success(''),
+ Access => NoAccess(),
+ Keys => Success(''),
+ Both => NoAccess(),
+ },
+
+ ##_20
+ {
+ Name => 'exists() of existing element via hash ref',
+ Code => q{ my $ref = \%x; exists($ref->{C}) },
+ Norm => Success(1),
+ RO => Success(1),
+ Access => Success(1),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+ ## 21
+ {
+ Name => 'defined() of existing element via hash ref',
+ Code => q{ my $ref = \%x; defined($ref->{C}) },
+ Norm => Success(1),
+ RO => Success(1),
+ Access => Success(1),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+ ## 22
+ {
+ Name => 'exists() of non-existing element via hash ref',
+ Code => q{ my $ref = \%x; exists($ref->{Z5}) },
+ Norm => Success(''),
+ RO => Success(''),
+ Access => Success(''),
+ Keys => Success(''),
+ Both => Success(''),
+ },
+
+ ## 23
+ {
+ Name => 'defined() of non-existing element via hash ref',
+ Code => q{ my $ref = \%x; defined($ref->{Z6}) },
+ Norm => Success(''),
+ RO => Success(''),
+ Access => NoAccess(),
+ Keys => Success(''),
+ Both => NoAccess(),
+ },
+
+ ## 24
+ {
+ Name => 'reference existing element via hash ref',
+ Code => q{ my $ref = \%x; $a = $ref->{C} },
+ Norm => Success($C),
+ RO => Success($C),
+ Access => Success($C),
+ Keys => Success($C),
+ Both => Success($C),
+ },
+
+ ## 25
+ {
+ Name => 'reference non-existing element via hash ref',
+ Code => q{ my $ref = \%x; $a = $ref->{XX} },
+ Norm => Success(undef),
+ RO => Success(undef),
+ Access => NoAccess(),
+ Keys => Success(undef),
+ Both => NoAccess(),
+ },
+
+ ## 26
+ {
+ Name => 'add element via hash ref',
+ Code => q{ my $ref = \%x; $ref->{Z7} = $TMP },
+ Norm => Success($TMP),
+ RO => NoAdd(),
+ Access => Success($TMP),
+ Keys => NoAdd(),
+ Both => NoAdd(),
+ },
+
+
+
+ ## 27
+ {
+ Name => 'take ref of existing element',
+ Code => q{ $a = \$x{A}; $TMP},
+ Norm => Success($TMP),
+ RO => Success($TMP),
+ Access => Success($TMP),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ## 28
+ {
+ Name => 'take ref of non-existing element',
+ Code => q{ $a = \$x{Z8}; $TMP},
+ Norm => Success($TMP),
+ RO => NoAdd(),
+ Access => Success($TMP),
+ Keys => NoAdd(),
+ Both => NoAdd(),
+ },
+
+ ## 29
+ {
+ Name => 'defined() via ref for element that does exist',
+ Code => q{ my $ref = \$x{A}; defined($$ref) },
+ Norm => Success(1),
+ RO => Success(1),
+ Access => Success(1),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+
+ ## 30
+ {
+ Name => 'defined() via ref for element that does not exist',
+ Code => q{ my $ref = \$x{Z9}; defined($$ref) },
+ Norm => Success(''),
+ RO => NoAdd(), ## NoAdd due to the ref creation, not the defined()
+ Access => Success(''), ## key gets created before deref, so no error
+ Keys => NoAdd(), ## NoAdd due to the ref creation, not the defined()
+ Both => NoAdd(), ## NoAdd due to the ref creation, not the defined()
+ },
+
+ ## 31
+ {
+ Name => 'access via ref of key that does exist',
+ Code => q{ my $ref = \$x{C}; $a = $$ref },
+ Norm => Success($C),
+ RO => Success($C),
+ Access => Success($C),
+ Keys => Success($C),
+ Both => Success($C),
+ },
+
+ ## 31
+ {
+ Name => 'access via ref of key that does not exist',
+ Code => q{ my $ref = \$x{Z10}; $a = $$ref },
+ Norm => Success(undef),
+ RO => NoAdd(), ## NoAdd due to the ref creation, not the dereference
+ Access => Success(undef), ## key gets created before deref, so no error
+ Keys => NoAdd(), ## NoAdd due to the ref creation, not the dereference
+ Both => NoAdd(), ## NoAdd due to the ref creation, not the dereference
+ },
+
+ ## 33
+ {
+ Name => 'update via ref with same value',
+ Code => q{ my $ref = \$x{A}; $$ref = $TMP },
+ Norm => Success($TMP),
+ RO => NoMod(), #NoModKey(),
+ Access => Success($TMP),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ## 34
+ {
+ Name => 'check readonlyness',
+ Code => q{ Readonly::CheckHash(%x) },
+ Norm => Success(0),
+ RO => Success(1),
+ Access => Success(0),
+ Keys => Success(0),
+ Both => Success(0),
+ },
+
+
+ ## 35
+ {
+ Name => 'check readonlyness via hash ref',
+ Code => q{ my $ref = \%x; Readonly::CheckHash(%$ref) },
+ Norm => Success(0),
+ RO => Success(1),
+ Access => Success(0),
+ Keys => Success(0),
+ Both => Success(0),
+ },
+
+ ## 36
+ {
+ Name => 'check clampness',
+ Code => q{ Clamp::Check(%x) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_KEYS),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(CLAMP_KEYS),
+ Both => Success(CLAMP_ALL),
+ },
+
+ ## 37
+ {
+ Name => 'check clampness via hash ref',
+ Code => q{ my $ref = \%x; Clamp::Check(%$ref) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_KEYS),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(CLAMP_KEYS),
+ Both => Success(CLAMP_ALL),
+ },
+
+ ## 38
+ {
+ Name => 'check access clampness',
+ Code => q{ Clamp::CheckAccess(%x) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_NONE),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(CLAMP_NONE),
+ Both => Success(CLAMP_ACCESS),
+ },
+
+ ## 39
+ {
+ Name => 'check access clampness via hash ref',
+ Code => q{ my $ref = \%x; Clamp::CheckAccess(%$ref) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_NONE),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(CLAMP_NONE),
+ Both => Success(CLAMP_ACCESS),
+ },
+
+ ## 40
+ {
+ Name => 'check keys clampness',
+ Code => q{ Clamp::CheckKeys(%x) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_KEYS),
+ Access => Success(CLAMP_NONE),
+ Keys => Success(CLAMP_KEYS),
+ Both => Success(CLAMP_KEYS),
+ },
+
+ ## 41
+ {
+ Name => 'check keys via hash ref',
+ Code => q{ my $ref = \%x; Clamp::CheckKeys(%$ref) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_KEYS),
+ Access => Success(CLAMP_NONE),
+ Keys => Success(CLAMP_KEYS),
+ Both => Success(CLAMP_KEYS),
+ },
+
+ ## 41
+ {
+ Name => 'access nonexistant key via boolean test',
+ Code => q{ if ($x{Z11}) { 101 } else { 102 } },
+ Norm => Success(102),
+ RO => Success(102),
+ Access => NoAccess(),
+ Keys => Success(102),
+ Both => NoAccess(),
+ },
+
+
+ ##########################
+
+ ##
+ {
+ Name => 'set hash to itself',
+ Code => q{ %x = %x; DumpHash(%x) },
+ Norm => Success("[A${TMP}C${C}D${D}M${M}N${N}U<U>Z10<U>Z7${TMP}Z8<U>Z9<U>]"),
+ RO => NoModHash(),
+ Access => Success("[A${TMP}C${C}D${D}M${M}N${N}U<U>Z10<U>Z7${TMP}Z8<U>Z9<U>]"),
+ Keys => NoModHash(),
+ Both => NoModHash(),
+ },
+
+ ##
+ {
+ Name => 'set hash to (itself)',
+ Code => q{ %x = (%x); DumpHash(%x) },
+ Norm => Success("[A${TMP}C${C}D${D}M${M}N${N}U<U>Z10<U>Z7${TMP}Z8<U>Z9<U>]"),
+ RO => NoModHash(),
+ Access => Success("[A${TMP}C${C}D${D}M${M}N${N}U<U>Z10<U>Z7${TMP}Z8<U>Z9<U>]"),
+ Keys => NoModHash(),
+ Both => NoModHash(),
+ },
+
+ ##
+ {
+ Name => 'set hash to a sub list of elements already there',
+ Code => q{ %x = (A => $A, B => $B); DumpHash(%x) },
+ Norm => Success("[A${A}B${B}]"),
+ RO => NoModHash(),
+ Access => Success("[A${A}B${B}]"),
+ Keys => NoModHash(),
+ Both => NoModHash(),
+ },
+
+ ##
+ {
+ Name => 'set hash to a sub list of other elements',
+ Code => q{ %x = (Z3 => $A, Z4 => $B); DumpHash(%x) },
+ Norm => Success("[Z3${A}Z4${B}]"),
+ RO => NoModHash(),
+ Access => Success("[Z3${A}Z4${B}]"),
+ Keys => NoModHash(),
+ Both => NoModHash(),
+ },
+
+ ##
+ {
+ Name => 'set hash to an empty list',
+ Code => q{ %x = (); DumpHash(%x) },
+ Norm => Success("[]"),
+ RO => NoModHash(),
+ Access => Success("[]"),
+ Keys => NoModHash(),
+ Both => NoModHash(),
+ },
+
+ ##
+ {
+ Name => 'undef hash',
+ Code => q{ undef %x; DumpHash(%x) },
+ Norm => Success("[]"),
+ RO => NoMod(),
+ Access => Success("[]"),
+ Keys => NoMod(),
+ Both => NoMod(),
+ },
+);
+
+
+
+
+
+
+my @Tests2 =
+(
+ ##
+ {
+ Name => 'pre-check keys()',
+ Code => q{ Flatten(keys %x) },
+ Norm => Success("A|B|C|M|N|U"),
+ RO => Success("A|B|C|M|N|U"),
+ Access => Success("A|B|C|M|N|U"),
+ Keys => Success("A|B|C|M|N|U"),
+ Both => Success("A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'pre-check values()',
+ Code => q{ Flatten(values %x) },
+ Norm => Success("106|107|92|93|94|<U>"),
+ RO => Success("106|107|92|93|94|<U>"),
+ Access => Success("106|107|92|93|94|<U>"),
+ Keys => Success("106|107|92|93|94|<U>"),
+ Both => Success("106|107|92|93|94|<U>"),
+ },
+
+ ##
+ {
+ Name => 'pre-check %x',
+ Code => q{ Flatten(%x) },
+ Norm => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Keys => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'pre-check each()',
+ Code => q{
+ my @x;
+ while (my($k,$v) = each %x)
+ {
+ push @x, $k, $v;
+ };
+ Flatten(@x)
+ },
+ Norm => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Keys => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'clamp access',
+ Code => q{ Clamp::Access(%x) },
+ Norm => Success(0),
+ RO => Success(0),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(0),
+ Both => Success(CLAMP_ACCESS),
+ },
+
+ ##
+ {
+ Name => 'check keys() after access clamp',
+ Code => q{ Flatten(keys %x) },
+ Norm => Success("A|B|C|M|N|U"),
+ RO => Success("A|B|C|M|N|U"),
+ Access => Success("A|B|C|M|N|U"),
+ Keys => Success("A|B|C|M|N|U"),
+ Both => Success("A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check values() after access clamp',
+ Code => q{ Flatten(values %x) },
+ Norm => Success("106|107|92|93|94|<U>"),
+ RO => Success("106|107|92|93|94|<U>"),
+ Access => Success("106|107|92|93|94|<U>"),
+ Keys => Success("106|107|92|93|94|<U>"),
+ Both => Success("106|107|92|93|94|<U>"),
+ },
+
+ ##
+ {
+ Name => 'check %x after access clamp',
+ Code => q{ Flatten(%x) },
+ Norm => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Keys => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check each() after access clamp',
+ Code => q{
+ my @x;
+ while (my($k,$v) = each %x)
+ {
+ push @x, $k, $v;
+ };
+ Flatten(@x)
+ },
+ Norm => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Keys => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'delete a key from an access-clamped hash',
+ Code => q{ delete($x{B}) },
+ Norm => Success($B),
+ RO => NoDelete(),
+ Access => Success($B),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'check keys() after delete of B',
+ Code => q{ Flatten(keys %x) },
+ Norm => Success("A|C|M|N|U"),
+ RO => Success("A|B|C|M|N|U"),
+ Access => Success("A|C|M|N|U"),
+ Keys => Success("A|B|C|M|N|U"),
+ Both => Success("A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check values() after delete of B',
+ Code => q{ Flatten(values %x) },
+ Norm => Success("106|107|92|94|<U>"),
+ RO => Success("106|107|92|93|94|<U>"),
+ Access => Success("106|107|92|94|<U>"),
+ Keys => Success("106|107|92|93|94|<U>"),
+ Both => Success("106|107|92|93|94|<U>"),
+ },
+
+ ##
+ {
+ Name => 'check %x after delete of B',
+ Code => q{ Flatten(%x) },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check each() after delete of B',
+ Code => q{
+ my @x;
+ while (my($k,$v) = each %x)
+ {
+ push @x, $k, $v;
+ };
+ Flatten(@x)
+ },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'access a key deleted from an access-clamped hash',
+ Code => q{ $a = $x{B} },
+ Norm => Success(undef),
+ RO => Success($B), ## 'cause wasn't deleted above
+ Access => Success(undef),
+ Keys => Success($B), ## 'cause wasn't deleted above
+ Both => Success($B), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 'exists() non-existant (but approved) key from access-clamped hash',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## 'cause wasn't deleted above
+ Access => Success(''),
+ Keys => Success(1), ## 'cause wasn't deleted above
+ Both => Success(1), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 'defined() non-existant (but approved) key from access-clamped hash',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## 'cause wasn't deleted above
+ Access => Success(''),
+ Keys => Success(1), ## 'cause wasn't deleted above
+ Both => Success(1), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 're-insert removed key from access-clamped hash',
+ Code => q{ $x{B} = $TMP },
+ Norm => Success($TMP),
+ RO => NoMod(),
+ Access => Success($TMP),
+ Keys => Success($TMP), ## no error: not adding because not deleted above
+ Both => Success($TMP), ## no error: not adding because not deleted above
+ },
+
+ ##
+ {
+ Name => 'check keys() after B reinserted',
+ Code => q{ Flatten(keys %x) },
+ Norm => Success("A|B|C|M|N|U"),
+ RO => Success("A|B|C|M|N|U"),
+ Access => Success("A|B|C|M|N|U"),
+ Keys => Success("A|B|C|M|N|U"),
+ Both => Success("A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check values() after B reinserted',
+ Code => q{ Flatten(values %x) },
+ Norm => Success("106|107|92|94|96|<U>"),
+ RO => Success("106|107|92|93|94|<U>"),
+ Access => Success("106|107|92|94|96|<U>"),
+ Keys => Success("106|107|92|94|96|<U>"),
+ Both => Success("106|107|92|94|96|<U>"),
+ },
+
+ ##
+ {
+ Name => 'check %x after B reinserted',
+ Code => q{ Flatten(%x) },
+ Norm => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check each() after B reinserted',
+ Code => q{
+ my @x;
+ while (my($k,$v) = each %x)
+ {
+ push @x, $k, $v;
+ };
+ Flatten(@x)
+ },
+ Norm => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'access re-inserted key',
+ Code => q{ $a = $x{B} },
+ Norm => Success($TMP),
+ RO => Success($B), ## because not deleted or inserted
+ Access => Success($TMP),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ##
+ {
+ Name => 're-delete a key from an access-clamped hash',
+ Code => q{ delete($x{B}) },
+ Norm => Success($TMP),
+ RO => NoDelete(),
+ Access => Success($TMP),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'unclamp access #1',
+ Code => q{ Clamp::ClearAccess(%x) },
+ Norm => Success(CLAMP_ACCESS),
+ RO => Success(CLAMP_ACCESS),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(CLAMP_ACCESS),
+ Both => Success(CLAMP_ACCESS),
+ },
+
+ ##
+ {
+ Name => 'check keys() after re-delete of B',
+ Code => q{ Flatten(keys %x) },
+ Norm => Success("A|C|M|N|U"),
+ RO => Success("A|B|C|M|N|U"),
+ Access => Success("A|C|M|N|U"),
+ Keys => Success("A|B|C|M|N|U"),
+ Both => Success("A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check values() after re-delete of B',
+ Code => q{ Flatten(values %x) },
+ Norm => Success("106|107|92|94|<U>"),
+ RO => Success("106|107|92|93|94|<U>"),
+ Access => Success("106|107|92|94|<U>"),
+ Keys => Success("106|107|92|94|96|<U>"),
+ Both => Success("106|107|92|94|96|<U>"),
+ },
+
+ ##
+ {
+ Name => 'check %x after re-delete of B',
+ Code => q{ Flatten(%x) },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check each() after re-delete of B',
+ Code => q{
+ my @x;
+ while (my($k,$v) = each %x)
+ {
+ push @x, $k, $v;
+ };
+ Flatten(@x)
+ },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'access deleted key from unclamped hash',
+ Code => q{ $a = $x{B} },
+ Norm => Success(undef),
+ RO => Success($B), ## because not deleted or inserted
+ Access => Success(undef),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ##
+ {
+ Name => 'reclamp access #1',
+ Code => q{ Clamp::Access(%x) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_NONE),
+ Access => Success(CLAMP_NONE),
+ Keys => Success(CLAMP_NONE),
+ Both => Success(CLAMP_NONE),
+ },
+
+ ##
+ {
+ Name => 'access a deleted key across reclamping',
+ Code => q{ $a = $x{B} },
+ Norm => Success(undef),
+ RO => Success($B), ## 'cause wasn't deleted above
+ Access => Success(undef),
+ Keys => Success($TMP), ## 'cause wasn't deleted above
+ Both => Success($TMP), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 'exists() non-existant (but approved) key across reclamping',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## 'cause wasn't deleted above
+ Access => Success(''),
+ Keys => Success(1), ## 'cause wasn't deleted above
+ Both => Success(1), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 'defined() non-existant (but approved) key across reclamping',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## 'cause wasn't deleted above
+ Access => Success(''),
+ Keys => Success(1), ## 'cause wasn't deleted above
+ Both => Success(1), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 're-insert removed key across reclamping',
+ Code => q{ $x{B} = $TMP },
+ Norm => Success($TMP),
+ RO => NoMod(),
+ Access => Success($TMP),
+ Keys => Success($TMP), ## no error: not adding because not deleted above
+ Both => Success($TMP), ## no error: not adding because not deleted above
+ },
+
+ ##
+ {
+ Name => 'unclamp access #2',
+ Code => q{ Clamp::ClearAccess(%x) },
+ Norm => Success(CLAMP_ACCESS),
+ RO => Success(CLAMP_ACCESS),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(CLAMP_ACCESS),
+ Both => Success(CLAMP_ACCESS),
+ },
+
+ ##
+ {
+ Name => 'delete a key from a formerlly access-clamped hash',
+ Code => q{ delete($x{B}) },
+ Norm => Success($TMP),
+ RO => NoDelete(),
+ Access => Success($TMP),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'check keys() after non-clamp delete of B',
+ Code => q{ Flatten(keys %x) },
+ Norm => Success("A|C|M|N|U"),
+ RO => Success("A|B|C|M|N|U"),
+ Access => Success("A|C|M|N|U"),
+ Keys => Success("A|B|C|M|N|U"),
+ Both => Success("A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check values() after non-clamp delete of B',
+ Code => q{ Flatten(values %x) },
+ Norm => Success("106|107|92|94|<U>"),
+ RO => Success("106|107|92|93|94|<U>"),
+ Access => Success("106|107|92|94|<U>"),
+ Keys => Success("106|107|92|94|96|<U>"),
+ Both => Success("106|107|92|94|96|<U>"),
+ },
+
+ ##
+ {
+ Name => 'check %x after non-clamp delete of B',
+ Code => q{ Flatten(%x) },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check each() after non-clamp delete of B',
+ Code => q{
+ my @x;
+ while (my($k,$v) = each %x)
+ {
+ push @x, $k, $v;
+ };
+ Flatten(@x)
+ },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'reclamp access #2',
+ Code => q{ Clamp::Access(%x) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_NONE),
+ Access => Success(CLAMP_NONE),
+ Keys => Success(CLAMP_NONE),
+ Both => Success(CLAMP_NONE),
+ },
+
+ ##
+ {
+ Name => 'check keys() after non-clamp delete of B and re-clamp',
+ Code => q{ Flatten(keys %x) },
+ Norm => Success("A|C|M|N|U"),
+ RO => Success("A|B|C|M|N|U"),
+ Access => Success("A|C|M|N|U"),
+ Keys => Success("A|B|C|M|N|U"),
+ Both => Success("A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check values() after non-clamp delete of B and re-clamp',
+ Code => q{ Flatten(values %x) },
+ Norm => Success("106|107|92|94|<U>"),
+ RO => Success("106|107|92|93|94|<U>"),
+ Access => Success("106|107|92|94|<U>"),
+ Keys => Success("106|107|92|94|96|<U>"),
+ Both => Success("106|107|92|94|96|<U>"),
+ },
+
+ ##
+ {
+ Name => 'check %x after non-clamp delete of B and re-clamp',
+ Code => q{ Flatten(%x) },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'check each() after non-clamp delete of B and re-clamp',
+ Code => q{
+ my @x;
+ while (my($k,$v) = each %x)
+ {
+ push @x, $k, $v;
+ };
+ Flatten(@x)
+ },
+ Norm => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ RO => Success("106|107|92|93|94|<U>|A|B|C|M|N|U"),
+ Access => Success("106|107|92|94|<U>|A|C|M|N|U"),
+ Keys => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ Both => Success("106|107|92|94|96|<U>|A|B|C|M|N|U"),
+ },
+
+ ##
+ {
+ Name => 'access approved key deleted while unclamped',
+ Code => q{ $a = $x{B} },
+ Norm => NoAccess(),
+ RO => Success($B), ## because not deleted or inserted
+ Access => NoAccess(),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ##
+ {
+ Name => 'exists() approved key deleted while unclamped',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1),
+ Access => Success(''),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+ ##
+ {
+ Name => 'defined() approved key deleted while unclamped',
+ Code => q{ exists($x{B}) },
+ Norm => Success(''),
+ RO => Success(1), ## because not deleted or inserted
+ Access => Success(''),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+ ##
+ {
+ Name => 'delete another key from an access-clamped hash',
+ Code => q{ delete($x{C}) },
+ Norm => Success($C),
+ RO => NoDelete(),
+ Access => Success($C),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'access non-existant (but approved) key from access-clamped hash',
+ Code => q{ $a = $x{C} },
+ Norm => Success(undef),
+ RO => Success($C), ## 'cause wasn't deleted above
+ Access => Success(undef),
+ Keys => Success($C), ## 'cause wasn't deleted above
+ Both => Success($C), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 'get ref to non-existant (but approved) key from access-clamped hash',
+ Code => q{ $a = \$x{C}; 1 },
+ Norm => Success(1),
+ RO => Success(1),
+ Access => Success(1),
+ Keys => Success(1),
+ Both => Success(1),
+ },
+
+ ##
+ {
+ Name => 'delete yet another key from an access-clamped hash',
+ Code => q{ delete($x{A}) },
+ Norm => Success($A),
+ RO => NoDelete(),
+ Access => Success($A),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'delete a forth key from an access-clamped hash',
+ Code => q{ delete($x{N}) },
+ Norm => Success($N),
+ RO => NoDelete(),
+ Access => Success($N),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'deref ref to non-existant (but approved) key from access-clamped hash',
+ Code => q{ my $ref = \$x{A}; $$ref },
+ Norm => Success(undef),
+ RO => Success($A), ## 'cause wasn't deleted above
+ Access => Success(undef),
+ Keys => Success($A), ## 'cause wasn't deleted above
+ Both => Success($A), ## 'cause wasn't deleted above
+ },
+
+ ##
+ {
+ Name => 'unclamp access #3',
+ Code => q{ Clamp::ClearAccess(%x) },
+ Norm => Success(CLAMP_ACCESS),
+ RO => Success(CLAMP_ACCESS),
+ Access => Success(CLAMP_ACCESS),
+ Keys => Success(CLAMP_ACCESS),
+ Both => Success(CLAMP_ACCESS),
+ },
+
+ ##
+ {
+ Name => 'delete existant key from no-longer-access-clamped hash',
+ Code => q{ delete($x{M}) },
+ Norm => Success($M),
+ RO => NoDelete(),
+ Access => Success($M),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'delete pre-deleted key from no-longer-access-clamped hash',
+ Code => q{ delete($x{N}) },
+ Norm => Success(undef),
+ RO => NoDelete(),
+ Access => Success(undef),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 'delete auto-vivified key from no-longer-access-clamped hash',
+ Code => q{ delete($x{A}) },
+ Norm => Success(undef),
+ RO => NoDelete(),
+ Access => Success(undef),
+ Keys => NoDelete(),
+ Both => NoDelete(),
+ },
+
+ ##
+ {
+ Name => 're-clamp access',
+ Code => q{ Clamp::Access(%x) },
+ Norm => Success(CLAMP_NONE),
+ RO => Success(CLAMP_NONE),
+ Access => Success(CLAMP_NONE),
+ Keys => Success(CLAMP_NONE),
+ Both => Success(CLAMP_NONE),
+ },
+
+ ##
+ {
+ Name => 'add new (but approved) key #1 to re-clamped hash',
+ Code => q{ $x{N} = $TMP },
+ Norm => Success($TMP),
+ RO => NoMod(),
+ Access => Success($TMP),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ##
+ {
+ Name => 'add new (but approved) key #2 to re-clamped hash',
+ Code => q{ $x{M} = $TMP },
+ Norm => Success($TMP),
+ RO => NoMod(),
+ Access => Success($TMP),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+ ##
+ {
+ Name => 'add new (but approved) key #3 to re-clamped hash',
+ Code => q{ $x{A} = $TMP },
+ Norm => Success($TMP),
+ RO => NoMod(),
+ Access => Success($TMP),
+ Keys => Success($TMP),
+ Both => Success($TMP),
+ },
+
+);
+
+
+##
+## We do @Tests checks for each @Setting...
+##
+my $Extra = 25;
+my $Total = @Setting * (@Tests1 + @Tests2) + $Extra;
+
+my $val;
+
+print "1..$Total\n";
+
+for my $tests (\@Tests1, \@Tests2)
+{
+ for my $setting (@Setting)
+ {
+ ##
+ ## Prepare hash that we'll work with.
+ ##
+ my %x = (A => $A,
+ B => $B,
+ C => $C,
+ M => $M,
+ N => $N,
+ U => undef);
+
+ ## Prepare the setting....
+ eval $setting->{Prep};
+ if ($@) {
+ die "bad prep { $setting->{Prep} }: $@\n\t";
+ }
+
+ ##
+ ## Run each test....
+ ##
+ for my $test (@$tests)
+ {
+ undef $@;
+
+ ## Actually do the test
+ $val = eval $test->{Code};
+
+ Check($setting->{Prep},
+ $test->{Name},
+ $val,
+ $@,
+ $test->{$setting->{Test}});
+ }
+ }
+}
+
+######################################################################
+######################################################################
+
+my %x = (A => 1,
+ B => 2,
+ C => 3);
+
+$val = eval { Readonly::CheckHash(%x) };
+Check('Extra Tests', "check readonlyness #1 (not readonly)",
+ $val, $@, 0);
+
+######################################################################
+$val = eval { Readonly::Hash(%x) };
+Check('Extra Tests', "set readonlyness",
+ $val, $@, 0);
+
+######################################################################
+$val = eval { Readonly::CheckHash(%x) };
+Check('Extra Tests', "check readonlyness #2 (now readonly)",
+ $val, $@, 1);
+
+######################################################################
+$val = eval { Readonly::Clear($x{B}) };
+Check('Extra Tests', "clear readonlyness from a value",
+ $val, $@, 1);
+
+######################################################################
+$val = eval { Readonly::CheckHash(%x) };
+Check('Extra Tests', "check readonlyness #3 (no longer readonly)",
+ $val, $@, 0);
+
+######################################################################
+$val = eval { Readonly::Set($x{B}) };
+Check('Extra Tests', "reset readonlyness of a key",
+ $val, $@, 0);
+
+######################################################################
+$val = eval { Readonly::CheckHash(%x) };
+Check('Extra Tests', "check readonlyness #4 (readonly again)",
+ $val, $@, 1);
+
+######################################################################
+$val = eval { Readonly::Clear($x{XX}) };
+Check('Extra Tests', 'clear readonlyness from nonexistant key',
+ $val, $@, NoAdd());
+
+
+######################################################################
+######################################################################
+
+my $ref;
+$val = eval { $ref = \$x{C}; 1 };
+Check('Extra Tests', "get ref",
+ $val, $@, 1);
+
+######################################################################
+$val = eval { Readonly::Set($ref) };
+Check('Extra Tests', "set readonlyness of ref",
+ $val, $@, 0);
+
+######################################################################
+$val = eval { Readonly::Clear($$ref) };
+Check('Extra Tests', "clear readonlyness through ref",
+ $val, $@, 1);
+
+######################################################################
+$val = eval { Readonly::CheckHash(%x) };
+Check('Extra Tests', "check readonlyness #5 (not readonly again)",
+ $val, $@, 0);
+
+
+
+
+######################################################################
+######################################################################
+
+$val = eval { Readonly::CheckHash(%ENV) };
+Check('Extra Tests', 'check readonlyness of %ENV',
+ $val, $@, 0);
+
+######################################################################
+$val = eval { Readonly::Hash(%ENV) };
+Check('Extra Tests', 'set readonlyness of %ENV',
+ $val, $@, NoSpecial());
+
+######################################################################
+$val = eval { Readonly::ClearHash(%ENV) };
+Check('Extra Tests', 'clear readonlyness of %ENV',
+ $val, $@, NoSpecial());
+
+
+
+######################################################################
+######################################################################
+{
+ our %Y = (A1 => 1,
+ A2 => 2,
+ A3 => 3,
+ A4 => 4,
+ A5 => 5,
+ A6 => 6,
+ A7 => 7,
+ A8 => 8,
+ A9 => 9,
+ A10 => 10,
+ A11 => 11,
+ A12 => 12,
+ A13 => 13,
+ A14 => 14,
+ A15 => 15,
+ A16 => 16,
+ A17 => 17,
+ A18 => 18,
+ A19 => 19,
+ A20 => 20);
+
+ $val = eval { scalar(keys %Y) };
+ Check('Extra Tests', 'check of global scalar(keys) - 1',
+ $val, $@, 20);
+
+ ####################################################
+ $val = eval {
+ delete $Y{A1};
+ delete $Y{A4};
+ delete $Y{A8};
+ };
+ Check('Extra Tests', 'check of global scalar(keys) - 2',
+ $val, $@, 8);
+
+ ####################################################
+ $val = eval { scalar(keys %Y) };
+ Check('Extra Tests', 'check of global scalar(keys) - 3',
+ $val, $@, 17);
+
+ ####################################################
+ $val = eval {
+ delete $Y{A2};
+ delete $Y{A5};
+ delete $Y{A15};
+ delete $Y{A17};
+ delete $Y{A7};
+ delete $Y{A16};
+ };
+ Check('Extra Tests', 'check of global scalar(keys) - 4',
+ $val, $@, 16);
+
+ ####################################################
+ $val = eval { scalar(keys %Y) };
+ Check('Extra Tests', 'check of global scalar(keys) - 5',
+ $val, $@, 11);
+
+}
+
+
+######################################################################
+######################################################################
+{
+ my %Y = (A1 => 1,
+ A2 => 2,
+ A3 => 3,
+ A4 => 4,
+ A5 => 5,
+ A6 => 6,
+ A7 => 7,
+ A8 => 8,
+ A9 => 9,
+ A10 => 10,
+ A11 => 11,
+ A12 => 12,
+ A13 => 13,
+ A14 => 14,
+ A15 => 15,
+ A16 => 16,
+ A17 => 17,
+ A18 => 18,
+ A19 => 19,
+ A20 => 20);
+
+ $val = eval { scalar(keys %Y) };
+ Check('Extra Tests', 'check of lexical scalar(keys) - 1',
+ $val, $@, 20);
+
+ ####################################################
+ $val = eval {
+ delete $Y{A1};
+ delete $Y{A4};
+ delete $Y{A8};
+ };
+ Check('Extra Tests', 'check of lexical scalar(keys) - 2',
+ $val, $@, 8);
+
+ ####################################################
+ $val = eval { scalar(keys %Y) };
+ Check('Extra Tests', 'check of lexical scalar(keys) - 3',
+ $val, $@, 17);
+
+ ####################################################
+ $val = eval {
+ delete $Y{A2};
+ delete $Y{A5};
+ delete $Y{A15};
+ delete $Y{A17};
+ delete $Y{A7};
+ delete $Y{A16};
+ };
+ Check('Extra Tests', 'check of lexical scalar(keys) - 4',
+ $val, $@, 16);
+
+ ####################################################
+ $val = eval { scalar(keys %Y) };
+ Check('Extra Tests', 'check of lexical scalar(keys) - 5',
+ $val, $@, 11);
+
+}
+
+###################################################
+## If tests are added here, update $Extra above ##
+###################################################
--- bleedperl.orig/ext/Readonly/t/scalar.t Sat Jul 28 21:32:36 2001
+++ bleedperl/ext/Readonly/t/scalar.t Sat Jul 28 20:20:55 2001
@@ -0,0 +1,381 @@
+#!./perl -w
+
+##
+## Basic test suite for Readonly scalars
+##
+## Use with -v option to get info on failed tests.
+##
+## Use with -vv option to get info on all tests.
+##
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw[../lib ../../../lib .];
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bReadonly\b/) {
+ print "1..0 # Skip: was not built\n";
+ exit 0;
+ }
+
+
+ ## put into @INC the directory in which this file lies
+ my $thisdir = __FILE__;
+ $thisdir =~ s{/[^/]+$}{};
+ push @INC, $thisdir;
+}
+
+use Readonly;
+use common;
+use strict;
+
+
+our $verbose = 0;
+
+##
+## Check args (-v shows failed test info, -vv shows all test info)
+##
+while (@ARGV and $ARGV[0] =~ m/^-/)
+{
+ my $arg = shift;
+ if ($arg =~ m/^-(v+)$/) {
+ $verbose += length $1;
+ }
+ else
+ {
+ die << "--DIE--";
+$0: bad arg [$arg]
+Usage: $0 [-v|-vv]
+--DIE--
+ }
+}
+
+my @Setting =
+(
+ {
+ Test => 'Norm',
+ Prep => q{ # normal scalar }, ## normal unmolested hashes
+ },
+ {
+ Test => 'RO',
+ Prep => q{ Readonly::Set($x);Readonly::Set($y);Readonly::Set($X);Readonly::Set($Y) },
+ },
+
+ {
+ Test => 'Norm',
+ Prep => q{ Readonly::Set($x);Readonly::Set($y);Readonly::Set($X);Readonly::Set($Y);
+ Readonly::Clear($x);Readonly::Clear($y);Readonly::Clear($X);Readonly::Clear($Y); },
+ },
+);
+
+my $TMPVAL = 9;
+
+my @Tests =
+(
+ {
+ Name => 'access lexical that has no value',
+ Code => q{ $a = $x },
+ Norm => Success(undef),
+ RO => Success(undef),
+ },
+ {
+ Name => 'access global that has no value',
+ Code => q{ $a = $X },
+ Norm => Success(undef),
+ RO => Success(undef),
+ },
+ {
+ Name => 'access lexical that has a value',
+ Code => q{ $a = $z },
+ Norm => Success($TMPVAL),
+ RO => Success($TMPVAL),
+ },
+ {
+ Name => 'access global that has a value',
+ Code => q{ $a = $Z },
+ Norm => Success($TMPVAL),
+ RO => Success($TMPVAL),
+ },
+
+ {
+ Name => 'write lexical that has no value',
+ Code => q{ $x = 1 },
+ Norm => Success(1),
+ RO => NoMod(),
+ },
+ {
+ Name => 'write lexical that has a value',
+ Code => q{ $x = 2 },
+ Norm => Success(2),
+ RO => NoMod(),
+ },
+
+ {
+ Name => 'undef lexical with no value',
+ Code => q{ undef $y },
+ Norm => Success(undef),
+ RO => NoMod(),
+ },
+ {
+ Name => 'undef lexical with a value',
+ Code => q{ undef $x },
+ Norm => Success(undef),
+ RO => NoMod(),
+ },
+ {
+ Name => 'cover with another variable',
+ Code => q{ my $x = 3; $x },
+ Norm => Success(3),
+ RO => Success(3),
+ },
+
+ {
+ Name => 'write global that has no value',
+ Code => q{ $X = 1 },
+ Norm => Success(1),
+ RO => NoMod(),
+ },
+ {
+ Name => 'write global that has a value',
+ Code => q{ $X = 2 },
+ Norm => Success(2),
+ RO => NoMod(),
+ },
+
+ {
+ Name => 'undef global with no value',
+ Code => q{ undef $Y },
+ Norm => Success(undef),
+ RO => NoMod(),
+ },
+ {
+ Name => 'undef global with a value',
+ Code => q{ undef $X },
+ Norm => Success(undef),
+ RO => NoMod(),
+ },
+ {
+ Name => 'cover with lexcial variable',
+ Code => q{ my $X = 3; $X },
+ Norm => Success(3),
+ RO => Success(3),
+ },
+ {
+ Name => 'cover with global variable',
+ Code => q{ local($X) = 3; $X },
+ Norm => Success(3),
+ RO => Success(3),
+ },
+ {
+ Name => 'update via ref of readonly lexical',
+ Code => q{ my $ref = \$y; $$ref = 3},
+ Norm => Success(3),
+ RO => NoMod(),
+ },
+ {
+ Name => 'update via ref of readonly global',
+ Code => q{ my $ref = \$Y; $$ref = 3},
+ Norm => Success(3),
+ RO => NoMod(),
+ },
+);
+
+
+##
+## We do @Tests checks for each @Setting...
+##
+my $Extra = 15;
+my $Total = @Setting * @Tests + $Extra;
+
+print "1..$Total\n";
+
+my $a;
+my $val;
+
+our $X;
+our $Y;
+our $Z;
+
+for my $setting (@Setting)
+{
+ ##
+ ## Prepare variables that we'll work with.
+ ##
+ my $x;
+ my $y;
+ my $z;
+ local($X);
+ local($Y);
+ local($Z);
+
+ $z = $Z = $TMPVAL;
+
+ ## Prepare the setting....
+ eval $setting->{Prep};
+ if ($@) {
+ die "bad prep { $setting->{Prep} }: $@\n\t";
+ }
+
+ ##
+ ## Run each test....
+ ##
+ for my $test (@Tests)
+ {
+ undef $@;
+
+ ## Actually do the test
+ $val = eval $test->{Code};
+
+ Check($setting->{Prep},
+ $test->{Name},
+ $val,
+ $@,
+ $test->{$setting->{Test}});
+ }
+}
+
+######################################################################
+my @Nums;
+@Nums = (1,2,3);
+
+for my $i (@Nums)
+{
+ my $orig = $i;
+ $val = eval { $i *= 2 };
+ Check('Extra Tests', "before loop variable readonly (1-$orig)",
+ $val, $@, Success($orig * 2));
+
+ Readonly::Set($i);
+
+ $val = eval { $i *= 2 };
+ Check('Extra Tests', "after loop variable readonly (1-$orig)",
+ $val, $@, NoMod());
+}
+
+######################################################################
+##
+## What happens if we make a loop variable readonly before we use it?
+##
+$val = eval {
+ my $i = 100;
+ my $total = 0;
+
+ Readonly::Set($i);
+
+ ## $i is readonly, but foreach does a type of 'local()' over it
+ foreach $i (1, 2, 3) {
+ $total += $i;
+ }
+ $total + $i
+};
+
+Check('Extra Tests', "using RO variable as foreach iterator",
+ $val, $@, 106);
+
+######################################################################
+##
+## What happens if we make a loop variable readonly before we use it?
+##
+$val = eval {
+ our $i = 100;
+ my $total = 0;
+
+ Readonly::Set($i);
+
+ ## $i is readonly, but foreach does a type of 'local()' over it
+ foreach $i (1, 2, 3) {
+ $total += $i;
+ }
+ $total + $i
+};
+
+Check('Extra Tests', "using RO global as foreach iterator",
+ $val, $@, 106);
+
+######################################################################
+$val = eval {
+ my $i = 100;
+ Readonly::Set($i);
+ {
+ my $i = 200;
+ $i *= 2;
+ }
+ $i;
+};
+
+Check('Extra Tests', "hide readonly lexical #1",
+ $val, $@, 100);
+
+######################################################################
+$val = eval {
+ my $i = 100;
+ Readonly::Set($i);
+ {
+ my $i = 200;
+ $i *= 2;
+ }
+ $i *= 2;
+ $i;
+};
+
+Check('Extra Tests', "hide readonly lexical #2",
+ $val, $@, NoMod());
+
+######################################################################
+$val = eval {
+ my $i = 100;
+ my $z;
+ {
+ my $i = 25;
+ Readonly::Set($i);
+
+ $z = $i *= 2;
+ }
+
+ $i *= 2;
+ $i;
+};
+
+Check('Extra Tests', "hide lexical with readonly #1",
+ $val, $@, NoMod);
+
+
+######################################################################
+$val = eval {
+ my $i = 100;
+ my $z;
+ {
+ my $i = 25;
+ Readonly::Set($i);
+ $z = $i;
+ }
+ $i *= 2;
+ $i;
+};
+
+Check('Extra Tests', "hide lexical with readonly #2",
+ $val, $@, 200);
+
+
+######################################################################
+######################################################################
+"abc" =~ m/a(b)c/;
+
+$val = eval { Readonly::Check($1) };
+Check('Extra Tests', 'check readonlyness of $1',
+ $val, $@, 1);
+
+######################################################################
+$val = eval { Readonly::Set($1) };
+Check('Extra Tests', 'set readonlyness of $1',
+ $val, $@, NoSpecial());
+
+######################################################################
+$val = eval { Readonly::Clear($1) };
+Check('Extra Tests', 'clear readonlyness of $1',
+ $val, $@, NoSpecial());
+
+
+
+###################################################
+## If tests are added here, update $Extra above ##
+###################################################
--- bleedperl.orig/ext/Readonly/t/common.pm Sat Jul 28 21:32:37 2001
+++ bleedperl/ext/Readonly/t/common.pm Sat Jul 28 16:29:01 2001
@@ -0,0 +1,135 @@
+use strict;
+
+our $verbose;
+
+##
+## When we set up the tests, one of the following is used to indicate
+## what we expect. For errors, we return a regex object that will match
+## the error we're expecting.
+##
+sub Success($)
+{
+ return $_[0];
+}
+
+sub NoAccess()
+{
+ return qr/Can't access nonexistant key/;
+}
+
+sub NoAdd()
+{
+ return qr/Can't add a new key/;
+}
+
+sub NoDelete()
+{
+ return qr/Can't delete key/;
+}
+
+sub NoMod()
+{
+ return qr/Modification of a read-only/;
+}
+
+sub NoModKey()
+{
+ return qr/Can't modify readonly value for key/;
+}
+
+sub NoModHash()
+{
+ return qr/Can't modify readonly.clamped hash/;
+}
+
+sub NoSpecial()
+{
+ return qr/Can't modify readonlyness of special variable/;
+}
+
+our $TESTNUM = 0;
+
+##
+## Given the results of a single test, compare to what's expected and
+## report appropriately.
+##
+sub Check($$$$$)
+{
+ my $which = shift;
+ my $name = shift;
+ my $got = shift;
+ my $err = shift;
+ my $wanted = shift;
+
+ my $okay = 0; ## set true if we got what we expected.
+
+ if ($err)
+ {
+ $err =~ s/at \(eval.*//s;
+ $got = $err;
+
+ if (ref($wanted)) {
+ if ($err =~ $wanted) {
+ $okay = 1;
+ }
+ }
+ }
+ elsif (not ref($wanted))
+ {
+ if (defined($wanted)) {
+ if (defined($got) and $got eq $wanted) {
+ $okay = 1;
+ }
+ } else {
+ if (not defined($got)) {
+ $okay = 1;
+ }
+ }
+ }
+
+ ##
+ ## $okay now set appropriately.
+ ##
+
+ $TESTNUM++;
+
+ if ($verbose != 1)
+ {
+ if ($okay) {
+ print "ok $TESTNUM\n";
+ } else {
+ print "not ok $TESTNUM\n";
+ }
+
+ if (not $verbose) {
+ return;
+ }
+ }
+
+ ##
+ ## Need to show more info......
+ ##
+
+ $got = "<undef>" if not defined $got;
+ $wanted = "<undef>" if not defined $wanted;
+ ($wanted = "$wanted") =~ s/\?-xism://;
+
+ if (not $okay) {
+ print <<"------------";
+* For: $which
+* Test: $name
+* want: $wanted
+* got: $got
+
+------------
+ } elsif ($verbose > 1) {
+ print <<"------------";
+ OKAY: $which
+ Test: $name
+ got: $got
+
+------------
+ }
+}
+
+1;
Thread Next
-
[PATCH for discussion] clamp, round #2
by Jeffrey Friedl