Front page | perl.perl5.porters |
Postings from August 2001
Re: [PATCH for discussion] clamp, round #2
Thread Previous
|
Thread Next
From:
Tim Bunce
Date:
August 2, 2001 04:50
Subject:
Re: [PATCH for discussion] clamp, round #2
Message ID:
20010801155536.C27874@rad.ig.co.uk
My main objection to this is that I don't see the need to add the
concept of placeholder values. I don't think the gain is worth the
overheads.
- Four bytes per hash might not seem much but it soon adds up.
Have you checked the impact of adding 4 bytes to struct xpvhv in terms
of malloc overheads? Does it push malloc into using a larger bucket?
(in which case the overhead would be much larger per hash).
Why not use xpvhv.xnv_nv?
- Every check for SvIMMORTAL is now slower
- Many hash operations are now slower for all hashes (inc symbol tables)
just to support this 'placeholder' concept.
Here's a simpler and faster alternative: A delete() on a clamped hash
could set the value to &sv_undef (a 'hard' readonly undef), and
exists() on a clamped hash could return false if the value is &sv_undef.
Doing scalar keys() on a clamped hash should revert to iterating
through the hash (and perl4 and early versions of perl5 did) and thus
avoid the need for maintaining a seperate count.
Other issues:
Poor names for functions. The use of mixed case names for things
(like Readonly::Clear) that are essentially interfaces to internals
doesn't feel right. Neither does using function names that are
ambiguous without their package names. I'd rather see names like
set_readonly()
Also, rather than having separate functions for scalars and hashes (and
what about arrays) I'd rather see one set_readonly() function that
takes an extra parameter to indicate if it should also apply to the
contents of containers. Thus:
set_readonly(\$foo);
set_readonly(\%bar);
set_readonly(\%bar, 1);
set_readonly(\@baz);
set_readonly(\@baz, 1);
plus similar is_readonly() and unset_readonly().
More checks are needed in the XS code so immutable values (like sv_yes)
can't have their readonlyness removed.
The implementation of the placeholder checks in several places could use
the fact that the placeholder is readonly to split and share an existing
if() so there'd be (slightly) fewer slowdowns. But I'd far rather see
placeholders removed entirely, as above.
Tim.
On Sat, Jul 28, 2001 at 10:00:23PM -0700, Jeffrey Friedl wrote:
> + /*
> + * 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 Previous
|
Thread Next