else
return FALSE;
}
-
-/* AVHV: Support for treating arrays as if they were hashes. The
- * first element of the array should be a hash reference that maps
- * hash keys to array indices.
- */
-
-STATIC I32
-S_avhv_index_sv(pTHX_ SV* sv)
-{
- I32 index = SvIV(sv);
- if (index < 1)
- Perl_croak(aTHX_ "Bad index while coercing array into hash");
- return index;
-}
-
-STATIC I32
-S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
-{
- HV *keys;
- HE *he;
- STRLEN n_a;
-
- keys = avhv_keys(av);
- he = hv_fetch_ent(keys, keysv, FALSE, hash);
- if (!he)
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
- return avhv_index_sv(HeVAL(he));
-}
-
-HV*
-Perl_avhv_keys(pTHX_ AV *av)
-{
- SV **keysp = av_fetch(av, 0, FALSE);
- if (keysp) {
- SV *sv = *keysp;
- if (SvGMAGICAL(sv))
- mg_get(sv);
- if (SvROK(sv)) {
- sv = SvRV(sv);
- if (SvTYPE(sv) == SVt_PVHV)
- return (HV*)sv;
- }
- }
- Perl_croak(aTHX_ "Can't coerce array into hash");
- return Nullhv;
-}
-
-SV**
-Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
-{
- return av_store(av, avhv_index(av, keysv, hash), val);
-}
-
-SV**
-Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
-{
- return av_fetch(av, avhv_index(av, keysv, hash), lval);
-}
-
-SV *
-Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
-{
- HV *keys = avhv_keys(av);
- HE *he;
-
- he = hv_fetch_ent(keys, keysv, FALSE, hash);
- if (!he || !SvOK(HeVAL(he)))
- return Nullsv;
-
- return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
-}
-
-/* Check for the existence of an element named by a given key.
- *
- */
-bool
-Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
-{
- HV *keys = avhv_keys(av);
- HE *he;
-
- he = hv_fetch_ent(keys, keysv, FALSE, hash);
- if (!he || !SvOK(HeVAL(he)))
- return FALSE;
-
- return av_exists(av, avhv_index_sv(HeVAL(he)));
-}
-
-HE *
-Perl_avhv_iternext(pTHX_ AV *av)
-{
- HV *keys = avhv_keys(av);
- return hv_iternext(keys);
-}
-
-SV *
-Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
-{
- SV *sv = hv_iterval(avhv_keys(av), entry);
- return *av_fetch(av, avhv_index_sv(sv), TRUE);
-}
I32 gimme = GIMME_V;
I32 dokeys = (PL_op->op_type == OP_KEYS);
I32 dovalues = (PL_op->op_type == OP_VALUES);
- I32 realhv = (SvTYPE(hv) == SVt_PVHV);
if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
dokeys = dovalues = TRUE;
RETURN;
}
- keys = realhv ? hv : avhv_keys((AV*)hv);
+ keys = hv;
(void)hv_iterinit(keys); /* always reset iterator regardless */
if (gimme == G_VOID)
}
if (dovalues) {
PUTBACK;
- tmpstr = realhv ?
- hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
+ tmpstr = hv_iterval(hv,entry);
DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
(unsigned long)HeHASH(entry),
HvMAX(keys)+1,
else if (o->op_type == OP_AASSIGN) {
if (o->op_private & OPpASSIGN_COMMON)
sv_catpv(tmpsv, ",COMMON");
- if (o->op_private & OPpASSIGN_HASH)
- sv_catpv(tmpsv, ",HASH");
}
else if (o->op_type == OP_SASSIGN) {
if (o->op_private & OPpASSIGN_BACKWARDS)
p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last
p |I32 |apply |I32 type|SV** mark|SV** sp
ApM |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len
-Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
-Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash
-Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash
-Ap |SV** |avhv_store_ent |AV *ar|SV* keysv|SV* val|U32 hash
-Ap |HE* |avhv_iternext |AV *ar
-Ap |SV* |avhv_iterval |AV *ar|HE* entry
-Ap |HV* |avhv_keys |AV *ar
Apd |void |av_clear |AV* ar
Apd |SV* |av_delete |AV* ar|I32 key|I32 flags
Apd |bool |av_exists |AV* ar|I32 key
END_EXTERN_C
-#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
-s |I32 |avhv_index_sv |SV* sv
-s |I32 |avhv_index |AV* av|SV* sv|U32 hash
-#endif
-
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
s |I32 |do_trans_simple |SV *sv
s |I32 |do_trans_count |SV *sv
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
-s |int |do_maybe_phash |AV *ary|SV **lelem|SV **firstlelem \
- |SV **relem|SV **lastrelem
s |void |do_oddball |HV *hash|SV **relem|SV **firstrelem
s |CV* |get_db_sub |SV **svp|CV *cv
s |SV* |method_common |SV* meth|U32* hashp
#define append_list Perl_append_list
#define apply Perl_apply
#define apply_attrs_string Perl_apply_attrs_string
-#define avhv_delete_ent Perl_avhv_delete_ent
-#define avhv_exists_ent Perl_avhv_exists_ent
-#define avhv_fetch_ent Perl_avhv_fetch_ent
-#define avhv_store_ent Perl_avhv_store_ent
-#define avhv_iternext Perl_avhv_iternext
-#define avhv_iterval Perl_avhv_iterval
-#define avhv_keys Perl_avhv_keys
#define av_clear Perl_av_clear
#define av_delete Perl_av_delete
#define av_exists Perl_av_exists
#define sv_nolocking Perl_sv_nolocking
#define sv_nounlocking Perl_sv_nounlocking
#define nothreadhook Perl_nothreadhook
-#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
-#define avhv_index_sv S_avhv_index_sv
-#define avhv_index S_avhv_index
-#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#define do_trans_simple S_do_trans_simple
#define do_trans_count S_do_trans_count
#define path_is_absolute S_path_is_absolute
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
-#define do_maybe_phash S_do_maybe_phash
#define do_oddball S_do_oddball
#define get_db_sub S_get_db_sub
#define method_common S_method_common
#define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c)
#define apply(a,b,c) Perl_apply(aTHX_ a,b,c)
#define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d)
-#define avhv_delete_ent(a,b,c,d) Perl_avhv_delete_ent(aTHX_ a,b,c,d)
-#define avhv_exists_ent(a,b,c) Perl_avhv_exists_ent(aTHX_ a,b,c)
-#define avhv_fetch_ent(a,b,c,d) Perl_avhv_fetch_ent(aTHX_ a,b,c,d)
-#define avhv_store_ent(a,b,c,d) Perl_avhv_store_ent(aTHX_ a,b,c,d)
-#define avhv_iternext(a) Perl_avhv_iternext(aTHX_ a)
-#define avhv_iterval(a,b) Perl_avhv_iterval(aTHX_ a,b)
-#define avhv_keys(a) Perl_avhv_keys(aTHX_ a)
#define av_clear(a) Perl_av_clear(aTHX_ a)
#define av_delete(a,b,c) Perl_av_delete(aTHX_ a,b,c)
#define av_exists(a,b) Perl_av_exists(aTHX_ a,b)
#define sv_nolocking(a) Perl_sv_nolocking(aTHX_ a)
#define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a)
#define nothreadhook() Perl_nothreadhook(aTHX)
-#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
-#define avhv_index_sv(a) S_avhv_index_sv(aTHX_ a)
-#define avhv_index(a,b,c) S_avhv_index(aTHX_ a,b,c)
-#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#define do_trans_simple(a) S_do_trans_simple(aTHX_ a)
#define do_trans_count(a) S_do_trans_count(aTHX_ a)
#define path_is_absolute(a) S_path_is_absolute(aTHX_ a)
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
-#define do_maybe_phash(a,b,c,d,e) S_do_maybe_phash(aTHX_ a,b,c,d,e)
#define do_oddball(a,b,c) S_do_oddball(aTHX_ a,b,c)
#define get_db_sub(a,b) S_get_db_sub(aTHX_ a,b)
#define method_common(a,b) S_method_common(aTHX_ a,b)
"padav", "padhv");
$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
$priv{"aassign"}{64} = "COMMON";
-$priv{"aassign"}{32} = "PHASH";
$priv{"sassign"}{64} = "BKWARD";
$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont");
@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
Perl_Gv_AMupdate
Perl_gv_handler
Perl_apply_attrs_string
-Perl_avhv_delete_ent
-Perl_avhv_exists_ent
-Perl_avhv_fetch_ent
-Perl_avhv_store_ent
-Perl_avhv_iternext
-Perl_avhv_iterval
-Perl_avhv_keys
Perl_av_clear
Perl_av_delete
Perl_av_exists
}
}
- my Foo $var = Foo::->new;
+ my $var = Foo->new;
$var->{foo} = 42;
- # this will generate a compile-time error
+ # this will generate an error
$var->{zap} = 42;
# subclassing
Do B<not> update the %FIELDS hash directly, because it must be created
at compile-time for it to be fully useful, as is done by this pragma.
-If a typed lexical variable holding a reference is used to access a
-hash element and a package with the same name as the type has declared
-class fields using this pragma, then the operation is turned into an
-array access at compile time.
-
The related C<base> pragma will combine fields from base classes and any
fields declared using the C<fields> pragma. This enables field
inheritance to work properly.
overridden but will generate a warning if used together with the C<-w>
switch.
-The effect of all this is that you can have objects with named fields
-which are as compact and as fast arrays to access. This only works
-as long as the objects are accessed through properly typed variables.
-If the objects are not typed, access is only checked at run time.
-
The following functions are supported:
=over 8
=item new
-fields::new() creates and blesses a pseudo-hash comprised of the fields
-declared using the C<fields> pragma into the specified class.
+fields::new() creates and blesses a restricted-hash comprised of the
+fields declared using the C<fields> pragma into the specified class.
This makes it possible to write a constructor like this:
package Critter::Sounds;
use fields qw(cat dog bird);
sub new {
- my Critter::Sounds $self = shift;
+ my $self = shift;
$self = fields::new($self) unless ref $self;
$self->{cat} = 'meow'; # scalar element
@$self{'dog','bird'} = ('bark','tweet'); # slice
=item phash
-fields::phash() can be used to create and initialize a plain (unblessed)
-pseudo-hash. This function should always be used instead of creating
-pseudo-hashes directly.
-
-If the first argument is a reference to an array, the pseudo-hash will
-be created with keys from that array. If a second argument is supplied,
-it must also be a reference to an array whose elements will be used as
-the values. If the second array contains less elements than the first,
-the trailing elements of the pseudo-hash will not be initialized.
-This makes it particularly useful for creating a pseudo-hash from
-subroutine arguments:
-
- sub dogtag {
- my $tag = fields::phash([qw(name rank ser_num)], [@_]);
- }
-
-fields::phash() also accepts a list of key-value pairs that will
-be used to construct the pseudo hash. Examples:
-
- my $tag = fields::phash(name => "Joe",
- rank => "captain",
- ser_num => 42);
-
- my $pseudohash = fields::phash(%args);
+Pseudo-hashes have been removed from Perl as of 5.10. Consider using
+restricted hashes instead. Using fields::phash() will cause an error.
=back
=head1 SEE ALSO
L<base>,
-L<perlref/Pseudo-hashes: Using an array as a hash>
=cut
$VERSION = "1.02";
+use Hash::Util qw(lock_keys);
+
# some constants
sub _PUBLIC () { 1 }
sub _PRIVATE () { 2 }
sub new {
my $class = shift;
$class = ref $class if ref $class;
- return bless [\%{$class . "::FIELDS"}], $class;
+ my $self = bless {}, $class;
+ lock_keys(%$self, keys %{$class.'::FIELDS'});
+ return $self;
}
sub phash {
- my $h;
- my $v;
- if (@_) {
- if (ref $_[0] eq 'ARRAY') {
- my $a = shift;
- @$h{@$a} = 1 .. @$a;
- if (@_) {
- $v = shift;
- unless (! @_ and ref $v eq 'ARRAY') {
- require Carp;
- Carp::croak ("Expected at most two array refs\n");
- }
- }
- }
- else {
- if (@_ % 2) {
- require Carp;
- Carp::croak ("Odd number of elements initializing pseudo-hash\n");
- }
- my $i = 0;
- @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
- $i = 0;
- $v = [grep $i++ % 2, @_];
- }
- }
- else {
- $h = {};
- $v = [];
- }
- [ $h, @$v ];
+ die "Pseudo-hashes have been removed from Perl";
}
1;
use warnings;
use vars qw($DEBUG);
+use Test::More;
+
+
package B1;
use fields qw(b1 b2 b3);
use fields '_b1';
use fields qw(b1 _b2 b2);
-sub new { bless [], shift }
+sub new { fields::new(shift); }
package D1;
use base 'B1';
'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
);
-print "1..", int(keys %expect)+21, "\n";
+plan tests => keys(%expect) + 17;
my $testno = 0;
while (my($class, $exp) = each %expect) {
no strict 'refs';
my $fstr = fstr(\%{$class."::FIELDS"});
- print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp;
- print "ok ", ++$testno, "\n";
+ is( $fstr, $exp, "\%FIELDS check for $class" );
}
# Did we get the appropriate amount of warnings?
-print "not " unless $w == 1;
-print "ok ", ++$testno, "\n";
+is( $w, 1 );
# A simple object creation and AVHV attribute access test
my B2 $obj1 = D3->new;
my D3 $obj2 = $obj1;
$obj2->{b1} = "D3";
-print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3";
-print "ok ", ++$testno, "\n";
-
# We should get compile time failures field name typos
eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
-print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/;
-print "ok ", ++$testno, "\n";
+like $@, qr/^Attempt to access disallowed key 'notthere' in a restricted hash/;
# Slices
@$obj1{"_b1", "b1"} = (17, 29);
-print "not " unless "@$obj1[1,2]" eq "17 29";
-print "ok ", ++$testno, "\n";
-@$obj1[1,2] = (44,28);
-print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28";
-print "ok ", ++$testno, "\n";
-
-my $ph = fields::phash(a => 1, b => 2, c => 3);
-print "not " unless fstr($ph) eq 'a:1,b:2,c:3';
-print "ok ", ++$testno, "\n";
-
-$ph = fields::phash([qw/a b c/], [1, 2, 3]);
-print "not " unless fstr($ph) eq 'a:1,b:2,c:3';
-print "ok ", ++$testno, "\n";
+is_deeply($obj1, { b1 => 29, _b1 => 17 });
-$ph = fields::phash([qw/a b c/], [1]);
-print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a};
-print "ok ", ++$testno, "\n";
+@$obj1{'_b1', 'b1'} = (44,28);
+is_deeply($obj1, { b1 => 28, _b1 => 44 });
-eval '$ph = fields::phash("odd")';
-print "not " unless $@ && $@ =~ /^Odd number of/;
-print "ok ", ++$testno, "\n";
+eval { fields::phash };
+like $@, qr/^Pseudo-hashes have been removed from Perl/;
#fields::_dump();
{
package Foo;
use fields qw(foo bar);
- sub new { bless [], $_[0]; }
+ sub new { fields::new($_[0]) }
package main;
my Foo $a = Foo->new();
- $a->{foo} = ['a', 'ok ' . ++$testno, 'c'];
- $a->{bar} = { A => 'ok ' . ++$testno };
- print $a->{foo}[1], "\n";
- print $a->{bar}->{A}, "\n";
+ $a->{foo} = ['a', 'ok', 'c'];
+ $a->{bar} = { A => 'ok' };
+ is( $a->{foo}[1], 'ok' );
+ is( $a->{bar}->{A},, 'ok' );
}
# check if fields autovivify
package main;
my Bar $a = Bar::->new();
- $a->{foo} = ['a', 'ok ' . ++$testno, 'c'];
- $a->{bar} = { A => 'ok ' . ++$testno };
- print $a->{foo}[1], "\n";
- print $a->{bar}->{A}, "\n";
+ $a->{foo} = ['a', 'ok', 'c'];
+ $a->{bar} = { A => 'ok' };
+ is( $a->{foo}[1], 'ok' );
+ is( $a->{bar}->{A}, 'ok' );
}
package Test::Version;
use base qw(No::Version);
-print "# $No::Version::VERSION\nnot " unless $No::Version::VERSION =~ /set by base\.pm/;
-print "ok ", ++$testno ,"\n";
+::like( $No::Version::VERSION, qr/set by base.pm/ );
# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION
package Has::Version;
package Test::Version2;
use base qw(Has::Version);
-print "#$Has::Version::VERSION\nnot " unless $Has::Version::VERSION eq '42';
-print "ok ", ++$testno ," # Has::Version\n";
+::is( $Has::Version::VERSION, 42 );
package main;
};
eval $eval1;
-printf "# %s\nnot ", $@ if $@;
-print "ok ", ++$testno ," # eval1\n";
+is( $@, '' );
-print "# $Eval1::VERSION\nnot " unless $Eval1::VERSION == 1.01;
-print "ok ", ++$testno ," # Eval1::VERSION\n";
+is( $Eval1::VERSION, 1.01 );
-print "# $Eval2::VERSION\nnot " unless $Eval2::VERSION == 1.02;
-print "ok ", ++$testno ," # Eval2::VERSION\n";
+is( $Eval2::VERSION, 1.02 );
eval q{use base reallyReAlLyNotexists;};
-print "not " unless $@;
-print "ok ", ++$testno, " # really not I\n";
+like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
+ 'base with empty package');
eval q{use base reallyReAlLyNotexists;};
-print "not " unless $@;
-print "ok ", ++$testno, " # really not II\n";
+like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
+ ' still empty on 2nd load');
BEGIN { $Has::Version_0::VERSION = 0 }
package Test::Version3;
use base qw(Has::Version_0);
-print "#$Has::Version_0::VERSION\nnot " unless $Has::Version_0::VERSION == 0;
-print "ok ", ++$testno ," # Version_0\n";
+::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' );
=head2 Two-face references
Suppose you want to create an object which is accessible as both an
-array reference and a hash reference, similar to the
-L<pseudo-hash|perlref/"Pseudo-hashes: Using an array as a hash">
-builtin Perl type. Let's make it better than a pseudo-hash by
-allowing index 0 to be treated as a normal element.
+array reference and a hash reference.
package two_refs;
use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} };
if (LvTARGLEN(sv)) {
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
- if (SvTYPE(ahv) == SVt_PVHV) {
- HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
- if (he)
- targ = HeVAL(he);
- }
- else {
- SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
- if (svp)
- targ = *svp;
- }
+ HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
+ if (he)
+ targ = HeVAL(he);
}
else {
AV* av = (AV*)LvTARG(sv);
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
STRLEN n_a;
- if (SvTYPE(ahv) == SVt_PVHV) {
- HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
- if (he)
- value = HeVAL(he);
- }
- else {
- SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
- if (svp)
- value = *svp;
- }
+ HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
+ if (he)
+ value = HeVAL(he);
if (!value || value == &PL_sv_undef)
Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
}
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
- for (curop = ((LISTOP*)curop)->op_first;
- curop; curop = curop->op_sibling)
- {
- if (curop->op_type == OP_RV2HV &&
- ((UNOP*)curop)->op_first->op_type != OP_GV) {
- o->op_private |= OPpASSIGN_HASH;
- break;
- }
- }
if (!(left->op_private & OPpLVAL_INTRO)) {
OP *lastop = o;
PL_generation++;
badtype = "an ARRAY";
break;
case OP_RV2HV:
- if (svtype != SVt_PVHV) {
- if (svtype == SVt_PVAV) { /* pseudohash? */
- SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
- if (ksv && SvROK(*ksv)
- && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
- {
- break;
- }
- }
+ if (svtype != SVt_PVHV)
badtype = "a HASH";
- }
break;
case OP_RV2CV:
if (svtype != SVt_PVCV)
Perl_peep(pTHX_ register OP *o)
{
register OP* oldop = 0;
- STRLEN n_a;
if (!o || o->op_seq)
return;
break;
case OP_HELEM: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp, **indsvp, *sv;
- I32 ind;
+ SV *lexname;
+ SV **svp, *sv;
char *key = NULL;
STRLEN keylen;
SvREFCNT_dec(sv);
*svp = lexname;
}
-
- if ((o->op_private & (OPpLVAL_INTRO)))
- break;
-
- rop = (UNOP*)((BINOP*)o)->op_first;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
- break;
- lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!(SvFLAGS(lexname) & SVpad_TYPED))
- break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
- if (!fields || !GvHV(*fields))
- break;
- key = SvPV(*svp, keylen);
- indsvp = hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
- if (!indsvp) {
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
- key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
- }
- ind = SvIV(*indsvp);
- if (ind < 1)
- Perl_croak(aTHX_ "Bad index while coercing array into hash");
- rop->op_type = OP_RV2AV;
- rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_type = OP_AELEM;
- o->op_ppaddr = PL_ppaddr[OP_AELEM];
- sv = newSViv(ind);
- if (SvREADONLY(*svp))
- SvREADONLY_on(sv);
- SvFLAGS(sv) |= (SvFLAGS(*svp)
- & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
- SvREFCNT_dec(*svp);
- *svp = sv;
- break;
- }
-
- case OP_HSLICE: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp, **indsvp, *sv;
- I32 ind;
- char *key;
- STRLEN keylen;
- SVOP *first_key_op, *key_op;
-
- o->op_seq = PL_op_seqmax++;
- if ((o->op_private & (OPpLVAL_INTRO))
- /* I bet there's always a pushmark... */
- || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
- /* hmmm, no optimization if list contains only one key. */
- break;
- rop = (UNOP*)((LISTOP*)o)->op_last;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
- break;
- lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!(SvFLAGS(lexname) & SVpad_TYPED))
- break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
- if (!fields || !GvHV(*fields))
- break;
- /* Again guessing that the pushmark can be jumped over.... */
- first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
- ->op_first->op_sibling;
- /* Check that the key list contains only constants. */
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling)
- if (key_op->op_type != OP_CONST)
- break;
- if (key_op)
- break;
- rop->op_type = OP_RV2AV;
- rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_type = OP_ASLICE;
- o->op_ppaddr = PL_ppaddr[OP_ASLICE];
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling) {
- svp = cSVOPx_svp(key_op);
- key = SvPV(*svp, keylen);
- indsvp = hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
- if (!indsvp) {
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
- "in variable %s of type %s",
- key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
- }
- ind = SvIV(*indsvp);
- if (ind < 1)
- Perl_croak(aTHX_ "Bad index while coercing array into hash");
- sv = newSViv(ind);
- if (SvREADONLY(*svp))
- SvREADONLY_on(sv);
- SvFLAGS(sv) |= (SvFLAGS(*svp)
- & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
- SvREFCNT_dec(*svp);
- *svp = sv;
- }
- break;
- }
+ break;
+ }
default:
o->op_seq = PL_op_seqmax++;
/* Private for OP_AASSIGN */
#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
-#define OPpASSIGN_HASH 32 /* Assigning to possible pseudohash. */
/* Private for OP_SASSIGN */
#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */
(P) One of the internal hash routines was passed a null HV pointer.
-=item Bad index while coercing array into hash
-
-(F) The index looked up in the hash found as the 0'th element of a
-pseudo-hash is not legal. Index values must be at 1 or greater.
-See L<perlref>.
-
=item Badly placed ()'s
(A) You've accidentally run your script through B<csh> instead
localize a package variable of the same name, qualify it with the
package name.
-=item Can't localize pseudo-hash element
-
-(F) You said something like C<< local $ar->{'key'} >>, where $ar is a
-reference to a pseudo-hash. That hasn't been implemented yet, but you
-can get a similar effect by localizing the corresponding array element
-directly -- C<< local $ar->[$ar->[0]{'key'}] >>.
-
=item Can't localize through a reference
(F) You said something like C<local $$ref>, which Perl can't currently
close a pipe which hadn't been opened. This should have been caught
earlier as an attempt to close an unopened filehandle.
-=item No such pseudo-hash field "%s"
-
-(F) You tried to access an array as a hash, but the field name used is
-not defined. The hash at index 0 should map all valid field names to
-array indices for that to work.
-
-=item No such pseudo-hash field "%s" in variable %s of type %s
-
-(F) You tried to access a field of a typed variable where the type does
-not know about the field name. The field names are looked up in the
-%FIELDS hash in the type package at compile time. The %FIELDS hash is
-%usually set up with the 'fields' pragma.
-
=item No such signal: SIG%s
(W signal) You specified a signal name as a subscript to %SIG that was
second--glance appear to be an lvalue context may be fixed in a future
release.
-See L<perlref/"Pseudo-hashes: Using an array as a hash"> for specifics
-on how exists() acts when used on a pseudo-hash.
-
Use of a subroutine call, rather than a subroutine name, as an argument
to exists() is an error.
=head2 Pseudo-hashes: Using an array as a hash
-B<WARNING>: This section describes an experimental feature. Details may
-change without notice in future versions.
-
-B<NOTE>: The current user-visible implementation of pseudo-hashes
-(the weird use of the first array element) is deprecated starting from
-Perl 5.8.0 and will be removed in Perl 5.10.0, and the feature will be
-implemented differently. Not only is the current interface rather ugly,
-but the current implementation slows down normal array and hash use quite
-noticeably. The 'fields' pragma interface will remain available.
-
-Beginning with release 5.005 of Perl, you may use an array reference
-in some contexts that would normally require a hash reference. This
-allows you to access array elements using symbolic names, as if they
-were fields in a structure.
-
-For this to work, the array must contain extra information. The first
-element of the array has to be a hash reference that maps field names
-to array indices. Here is an example:
-
- $struct = [{foo => 1, bar => 2}, "FOO", "BAR"];
-
- $struct->{foo}; # same as $struct->[1], i.e. "FOO"
- $struct->{bar}; # same as $struct->[2], i.e. "BAR"
-
- keys %$struct; # will return ("foo", "bar") in some order
- values %$struct; # will return ("FOO", "BAR") in same some order
-
- while (my($k,$v) = each %$struct) {
- print "$k => $v\n";
- }
-
-Perl will raise an exception if you try to access nonexistent fields.
-To avoid inconsistencies, always use the fields::phash() function
-provided by the C<fields> pragma.
-
- use fields;
- $pseudohash = fields::phash(foo => "FOO", bar => "BAR");
-
-For better performance, Perl can also do the translation from field
-names to array indices at compile time for typed object references.
-See L<fields>.
-
-There are two ways to check for the existence of a key in a
-pseudo-hash. The first is to use exists(). This checks to see if the
-given field has ever been set. It acts this way to match the behavior
-of a regular hash. For instance:
-
- use fields;
- $phash = fields::phash([qw(foo bar pants)], ['FOO']);
- $phash->{pants} = undef;
-
- print exists $phash->{foo}; # true, 'foo' was set in the declaration
- print exists $phash->{bar}; # false, 'bar' has not been used.
- print exists $phash->{pants}; # true, your 'pants' have been touched
-
-The second is to use exists() on the hash reference sitting in the
-first array element. This checks to see if the given key is a valid
-field in the pseudo-hash.
-
- print exists $phash->[0]{bar}; # true, 'bar' is a valid field
- print exists $phash->[0]{shoes};# false, 'shoes' can't be used
-
-delete() on a pseudo-hash element only deletes the value corresponding
-to the key, not the key itself. To delete the key, you'll have to
-explicitly delete it from the first hash element.
-
- print delete $phash->{foo}; # prints $phash->[1], "FOO"
- print exists $phash->{foo}; # false
- print exists $phash->[0]{foo}; # true, key still exists
- print delete $phash->[0]{foo}; # now key is gone
- print $phash->{foo}; # runtime exception
+Pseudo-hashes have been removed from Perl. The 'fields' pragma
+remains available.
=head2 Function Templates
HV *hash = (HV*)POPs;
HE *entry;
I32 gimme = GIMME_V;
- I32 realhv = (SvTYPE(hash) == SVt_PVHV);
PUTBACK;
/* might clobber stack_sp */
- entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
+ entry = hv_iternext(hash);
SPAGAIN;
EXTEND(SP, 2);
SV *val;
PUTBACK;
/* might clobber stack_sp */
- val = realhv ?
- hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
+ val = hv_iterval(hash, entry);
SPAGAIN;
PUSHs(val);
}
*MARK = sv ? sv : &PL_sv_undef;
}
}
- else if (hvtype == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
- while (++MARK <= SP) {
- sv = av_delete((AV*)hv, SvIV(*MARK), discard);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
- else { /* pseudo-hash element */
- while (++MARK <= SP) {
- sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
+ else if (hvtype == SVt_PVAV) { /* array element */
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ while (++MARK <= SP) {
+ sv = av_delete((AV*)hv, SvIV(*MARK), discard);
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ }
}
else
DIE(aTHX_ "Not a HASH reference");
else if (SvTYPE(hv) == SVt_PVAV) {
if (PL_op->op_flags & OPf_SPECIAL)
sv = av_delete((AV*)hv, SvIV(keysv), discard);
- else
- sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
}
else
DIE(aTHX_ "Not a HASH reference");
if (av_exists((AV*)hv, SvIV(tmpsv)))
RETPUSHYES;
}
- else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
- RETPUSHYES;
}
else {
DIE(aTHX_ "Not a HASH reference");
dSP; dMARK; dORIGMARK;
register HV *hv = (HV*)POPs;
register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
- I32 realhv = (SvTYPE(hv) == SVt_PVHV);
bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
bool other_magic = FALSE;
&& gv_fetchmethod_autoload(stash, "DELETE", TRUE));
}
- if (!realhv && localizing)
- DIE(aTHX_ "Can't localize pseudo-hash element");
+ while (++MARK <= SP) {
+ SV *keysv = *MARK;
+ SV **svp;
+ HE *he;
+ bool preeminent = FALSE;
- if (realhv || SvTYPE(hv) == SVt_PVAV) {
- while (++MARK <= SP) {
- SV *keysv = *MARK;
- SV **svp;
- bool preeminent = FALSE;
+ if (localizing) {
+ preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
+ hv_exists_ent(hv, keysv, 0);
+ }
- if (localizing) {
- preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
- realhv ? hv_exists_ent(hv, keysv, 0)
- : avhv_exists_ent((AV*)hv, keysv, 0);
- }
+ he = hv_fetch_ent(hv, keysv, lval, 0);
+ svp = he ? &HeVAL(he) : 0;
- if (realhv) {
- HE *he = hv_fetch_ent(hv, keysv, lval, 0);
- svp = he ? &HeVAL(he) : 0;
- }
- else {
- svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
- }
- if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
- STRLEN n_a;
- DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
- }
- if (localizing) {
- if (preeminent)
- save_helem(hv, keysv, svp);
- else {
- STRLEN keylen;
- char *key = SvPV(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
- }
+ if (lval) {
+ if (!svp || *svp == &PL_sv_undef) {
+ STRLEN n_a;
+ DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
+ }
+ if (localizing) {
+ if (preeminent)
+ save_helem(hv, keysv, svp);
+ else {
+ STRLEN keylen;
+ char *key = SvPV(keysv, keylen);
+ SAVEDELETE(hv, savepvn(key,keylen), keylen);
}
- }
- *MARK = svp ? *svp : &PL_sv_undef;
- }
+ }
+ }
+ *MARK = svp ? *svp : &PL_sv_undef;
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
tryAMAGICunDEREF(to_hv);
hv = (HV*)SvRV(sv);
- if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
+ if (SvTYPE(hv) != SVt_PVHV)
DIE(aTHX_ "Not a HASH reference");
if (PL_op->op_flags & OPf_REF) {
SETs((SV*)hv);
}
}
else {
- if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
+ if (SvTYPE(sv) == SVt_PVHV) {
hv = (HV*)sv;
if (PL_op->op_flags & OPf_REF) {
SETs((SV*)hv);
}
else {
dTARGET;
- if (SvTYPE(hv) == SVt_PVAV)
- hv = avhv_keys((AV*)hv);
if (HvFILL(hv))
Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
(IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
}
}
-STATIC int
-S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
- SV **lastrelem)
-{
- OP *leftop;
- I32 i;
-
- leftop = ((BINOP*)PL_op)->op_last;
- assert(leftop);
- assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
- leftop = ((LISTOP*)leftop)->op_first;
- assert(leftop);
- /* Skip PUSHMARK and each element already assigned to. */
- for (i = lelem - firstlelem; i > 0; i--) {
- leftop = leftop->op_sibling;
- assert(leftop);
- }
- if (leftop->op_type != OP_RV2HV)
- return 0;
-
- /* pseudohash */
- if (av_len(ary) > 0)
- av_fill(ary, 0); /* clear all but the fields hash */
- if (lastrelem >= relem) {
- while (relem < lastrelem) { /* gobble up all the rest */
- SV *tmpstr;
- assert(relem[0]);
- assert(relem[1]);
- /* Avoid a memory leak when avhv_store_ent dies. */
- tmpstr = sv_newmortal();
- sv_setsv(tmpstr,relem[1]); /* value */
- relem[1] = tmpstr;
- if (avhv_store_ent(ary,relem[0],tmpstr,0))
- (void)SvREFCNT_inc(tmpstr);
- if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- relem += 2;
- TAINT_NOT;
- }
- }
- if (relem == lastrelem)
- return 1;
- return 2;
-}
-
STATIC void
S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
{
if (*relem) {
SV *tmpstr;
- if (ckWARN(WARN_MISC)) {
+ HE *didstore;
+
+ if (ckWARN(WARN_MISC)) {
if (relem == firstrelem &&
SvROK(*relem) &&
(SvTYPE(SvRV(*relem)) == SVt_PVAV ||
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Odd number of elements in hash assignment");
}
- if (SvTYPE(hash) == SVt_PVAV) {
- /* pseudohash */
- tmpstr = sv_newmortal();
- if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
- (void)SvREFCNT_inc(tmpstr);
- if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- }
- else {
- HE *didstore;
- tmpstr = NEWSV(29,0);
- didstore = hv_store_ent(hash,*relem,tmpstr,0);
- if (SvMAGICAL(hash)) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
- }
- }
- TAINT_NOT;
+
+ tmpstr = NEWSV(29,0);
+ didstore = hv_store_ent(hash,*relem,tmpstr,0);
+ if (SvMAGICAL(hash)) {
+ if (SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ if (!didstore)
+ sv_2mortal(tmpstr);
+ }
+ TAINT_NOT;
}
}
case SVt_PVAV:
ary = (AV*)sv;
magic = SvMAGICAL(ary) != 0;
- if (PL_op->op_private & OPpASSIGN_HASH) {
- switch (do_maybe_phash(ary, lelem, firstlelem, relem,
- lastrelem))
- {
- case 0:
- goto normal_array;
- case 1:
- do_oddball((HV*)ary, relem, firstrelem);
- }
- relem = lastrelem + 1;
- break;
- }
- normal_array:
av_clear(ary);
av_extend(ary, lastrelem - relem);
i = 0;
he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : 0;
}
- else if (SvTYPE(hv) == SVt_PVAV) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- DIE(aTHX_ "Can't localize pseudo-hash element");
- svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
- }
else {
RETPUSHUNDEF;
}
PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last);
PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp);
PERL_CALLCONV void Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, char *attrstr, STRLEN len);
-PERL_CALLCONV SV* Perl_avhv_delete_ent(pTHX_ AV *ar, SV* keysv, I32 flags, U32 hash);
-PERL_CALLCONV bool Perl_avhv_exists_ent(pTHX_ AV *ar, SV* keysv, U32 hash);
-PERL_CALLCONV SV** Perl_avhv_fetch_ent(pTHX_ AV *ar, SV* keysv, I32 lval, U32 hash);
-PERL_CALLCONV SV** Perl_avhv_store_ent(pTHX_ AV *ar, SV* keysv, SV* val, U32 hash);
-PERL_CALLCONV HE* Perl_avhv_iternext(pTHX_ AV *ar);
-PERL_CALLCONV SV* Perl_avhv_iterval(pTHX_ AV *ar, HE* entry);
-PERL_CALLCONV HV* Perl_avhv_keys(pTHX_ AV *ar);
PERL_CALLCONV void Perl_av_clear(pTHX_ AV* ar);
PERL_CALLCONV SV* Perl_av_delete(pTHX_ AV* ar, I32 key, I32 flags);
PERL_CALLCONV bool Perl_av_exists(pTHX_ AV* ar, I32 key);
END_EXTERN_C
-#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
-STATIC I32 S_avhv_index_sv(pTHX_ SV* sv);
-STATIC I32 S_avhv_index(pTHX_ AV* av, SV* sv, U32 hash);
-#endif
-
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
STATIC I32 S_do_trans_simple(pTHX_ SV *sv);
STATIC I32 S_do_trans_count(pTHX_ SV *sv);
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
-STATIC int S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, SV **lastrelem);
STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem);
STATIC CV* S_get_db_sub(pTHX_ SV **svp, CV *cv);
STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp);
#!./perl
+# This test was originally for pseudo-hashes. It now exists to ensure
+# they were properly removed in 5.9.
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
sub STORE { $_[0]->[$_[1]] = $_[2] }
sub FETCH { $_[0]->[$_[1]] }
sub FETCHSIZE { scalar(@{$_[0]})}
-sub STORESIZE { $#{$_[0]} = $_[1]+1 }
+sub STORESIZE { $#{$_[0]} = $_[1]+1 }
package main;
-print "1..29\n";
+require './test.pl';
+plan(tests => 40);
+
+# Helper function to check the typical error message.
+sub not_hash {
+ my($err) = shift;
+ like( $err, qr/^Not a HASH reference / ) ||
+ printf STDERR "# at %s line %d.\n", (caller)[1,2];
+}
+
+# Something to place inside if blocks and while loops that won't get
+# compiled out.
+my $foo = 42;
+sub no_op { $foo++ }
+
$sch = {
'abc' => 1,
$a = [];
$a->[0] = $sch;
-$a->{'abc'} = 'ABC';
-$a->{'def'} = 'DEF';
-$a->{'jkl'} = 'JKL';
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
-@keys = keys %$a;
-@values = values %$a;
+eval {
+ $a->{'def'} = 'DEF';
+};
+not_hash($@);
-if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";}
+eval {
+ $a->{'jkl'} = 'JKL';
+};
+not_hash($@);
-$i = 0; # stop -w complaints
+eval {
+ @keys = keys %$a;
+};
+not_hash($@);
+
+eval {
+ @values = values %$a;
+};
+not_hash($@);
-while (($key,$value) = each %$a) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
- $key =~ y/a-z/A-Z/;
- $i++ if $key eq $value;
+eval {
+ while( my($k,$v) = each %$a ) {
+ no_op;
}
-}
+};
+not_hash($@);
-if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";}
# quick check with tied array
tie @fake, 'Tie::StdArray';
$a = \@fake;
$a->[0] = $sch;
-$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
+
+eval {
+ if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
+};
+not_hash($@);
# quick check with tied array
tie @fake, 'Tie::BasicArray';
$a = \@fake;
$a->[0] = $sch;
-$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
+
+eval {
+ if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
+};
+not_hash($@);
# quick check with tied array & tied hash
require Tie::Hash;
%fake = %$sch;
$a->[0] = \%fake;
-$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
+
+eval {
+ if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
+};
+not_hash($@);
+
# hash slice
-my $slice = join('', 'x',@$a{'abc','def'},'x');
-print "not " if $slice ne 'xABCx';
-print "ok 6\n";
+eval {
+ my $slice = join('', 'x',@$a{'abc','def'},'x');
+};
+not_hash($@);
+
# evaluation in scalar context
my $avhv = [{}];
-print "not " if %$avhv;
-print "ok 7\n";
+
+eval {
+ () = %$avhv;
+};
+not_hash($@);
push @$avhv, "a";
-print "not " if %$avhv;
-print "ok 8\n";
+eval {
+ () = %$avhv;
+};
+not_hash($@);
$avhv = [];
eval { $a = %$avhv };
-print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;
-print "ok 9\n";
+not_hash($@);
$avhv = [{foo=>1, bar=>2}];
-print "not " unless %$avhv =~ m,^\d+/\d+,;
-print "ok 10\n";
+eval {
+ %$avhv =~ m,^\d+/\d+,;
+};
+not_hash($@);
# check if defelem magic works
sub f {
print "ok 11\n";
}
$a = [{key => 1}, 'a'];
-f($a->{key});
-print "not " unless $a->[1] eq 'b';
-print "ok 12\n";
+eval {
+ f($a->{key});
+};
+not_hash($@);
# check if exists() is behaving properly
$avhv = [{foo=>1,bar=>2,pants=>3}];
-print "not " if exists $avhv->{bar};
-print "ok 13\n";
+eval {
+ no_op if exists $avhv->{bar};
+};
+not_hash($@);
+
+eval {
+ $avhv->{pants} = undef;
+};
+not_hash($@);
-$avhv->{pants} = undef;
-print "not " unless exists $avhv->{pants};
-print "ok 14\n";
-print "not " if exists $avhv->{bar};
-print "ok 15\n";
+eval {
+ no_op if exists $avhv->{pants};
+};
+not_hash($@);
+
+eval {
+ no_op if exists $avhv->{bar};
+};
+not_hash($@);
-$avhv->{bar} = 10;
-print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10;
-print "ok 16\n";
+eval {
+ $avhv->{bar} = 10;
+};
+not_hash($@);
-$v = delete $avhv->{bar};
-print "not " unless $v == 10;
-print "ok 17\n";
+eval {
+ no_op unless exists $avhv->{bar} and $avhv->{bar} == 10;
+};
+not_hash($@);
-print "not " if exists $avhv->{bar};
-print "ok 18\n";
+eval {
+ $v = delete $avhv->{bar};
+};
+not_hash($@);
-$avhv->{foo} = 'xxx';
-$avhv->{bar} = 'yyy';
-$avhv->{pants} = 'zzz';
-@x = delete @{$avhv}{'foo','pants'};
-print "# @x\nnot " unless "@x" eq "xxx zzz";
-print "ok 19\n";
+eval {
+ no_op if exists $avhv->{bar};
+};
+not_hash($@);
-print "not " unless "$avhv->{bar}" eq "yyy";
-print "ok 20\n";
+eval {
+ $avhv->{foo} = 'xxx';
+};
+not_hash($@);
+eval {
+ $avhv->{bar} = 'yyy';
+};
+not_hash($@);
+eval {
+ $avhv->{pants} = 'zzz';
+};
+not_hash($@);
+eval {
+ @x = delete @{$avhv}{'foo','pants'};
+};
+not_hash($@);
+eval {
+ no_op unless "$avhv->{bar}" eq "yyy";
+};
+not_hash($@);
# hash assignment
-%$avhv = ();
-print "not " unless ref($avhv->[0]) eq 'HASH';
-print "ok 21\n";
+eval {
+ %$avhv = ();
+};
+not_hash($@);
-%hv = %$avhv;
-print "not " if grep defined, values %hv;
-print "ok 22\n";
-print "not " if grep ref, keys %hv;
-print "ok 23\n";
+eval {
+ %hv = %$avhv;
+};
+not_hash($@);
-%$avhv = (foo => 29, pants => 2, bar => 0);
-print "not " unless "@$avhv[1..3]" eq '29 0 2';
-print "ok 24\n";
+eval {
+ %$avhv = (foo => 29, pants => 2, bar => 0);
+};
+not_hash($@);
my $extra;
my @extra;
-($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo';
-print "ok 25\n";
-
-%$avhv = ();
-(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra;
-print "ok 26\n";
-
-@extra = qw(whatever and stuff);
-%$avhv = ();
-(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0;
-print "ok 27\n";
-
-%$avhv = ();
-(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6;
-print "ok 28\n";
+eval {
+ ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
+
+eval {
+ %$avhv = ();
+ (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
+
+eval {
+ @extra = qw(whatever and stuff);
+ %$avhv = ();
+};
+not_hash($@);
+eval {
+ (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
+
+eval {
+ (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
# Check hash slices (BUG ID 20010423.002)
$avhv = [{foo=>1, bar=>2}];
-@$avhv{"foo", "bar"} = (42, 53);
-print "not " unless $avhv->{foo} == 42 && $avhv->{bar} == 53;
-print "ok 29\n";
+eval {
+ @$avhv{"foo", "bar"} = (42, 53);
+};
+not_hash($@);
%hash = sub { print "ok" };
test_warning 6, shift @warnings, $odd_msg;
+ # Old pseudo-hash syntax, now removed.
my $avhv = [{x=>1,y=>2}];
- %$avhv = (x=>13,'y');
- test_warning 7, shift @warnings, $odd_msg;
-
- %$avhv = 'x';
- test_warning 8, shift @warnings, $odd_msg;
+ eval {
+ %$avhv = (x=>13,'y');
+ };
+ test 7, $@ =~ /^Not a HASH reference/;
+
+ # Old pseudo-hash syntax, since removed.
+ eval {
+ %$avhv = 'x';
+ };
+ test 8, $@ =~ /^Not a HASH reference/;
$_ = { 1..10 };
test 9, ! @warnings, "Unexpected warning";
projects / p5sagit/p5-mst-13.2.git / commitdiff