From 6d822dc4045278fb03135b2683bac92dba061369 Mon Sep 17 00:00:00 2001 From: "Michael G. Schwern" Date: Tue, 6 Aug 2002 06:05:10 -0700 Subject: [PATCH] Remove pseudo-hashes (complete) Message-id: <20020806200510.GC31473@ool-18b93024.dyn.optonline.net> p4raw-id: //depot/perl@17725 --- av.c | 101 ------------------- doop.c | 6 +- dump.c | 2 - embed.fnc | 14 --- embed.h | 24 ----- ext/B/B/Concise.pm | 1 - global.sym | 7 -- lib/fields.pm | 84 +++------------- lib/fields.t | 87 ++++++----------- lib/overload.pm | 5 +- mg.c | 26 ++--- op.c | 130 +----------------------- op.h | 1 - pod/perldiag.pod | 26 ----- pod/perlfunc.pod | 3 - pod/perlref.pod | 73 +------------- pp.c | 92 +++++++---------- pp_hot.c | 103 +++---------------- proto.h | 13 --- t/op/avhv.t | 282 ++++++++++++++++++++++++++++++++++++----------------- t/op/hashwarn.t | 16 ++- 21 files changed, 313 insertions(+), 783 deletions(-) diff --git a/av.c b/av.c index 4d73e40..3146f25 100644 --- a/av.c +++ b/av.c @@ -835,104 +835,3 @@ Perl_av_exists(pTHX_ AV *av, I32 key) 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); -} diff --git a/doop.c b/doop.c index f4f012f..7aee091 100644 --- a/doop.c +++ b/doop.c @@ -1280,7 +1280,6 @@ Perl_do_kv(pTHX) 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; @@ -1295,7 +1294,7 @@ Perl_do_kv(pTHX) RETURN; } - keys = realhv ? hv : avhv_keys((AV*)hv); + keys = hv; (void)hv_iterinit(keys); /* always reset iterator regardless */ if (gimme == G_VOID) @@ -1342,8 +1341,7 @@ Perl_do_kv(pTHX) } 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, diff --git a/dump.c b/dump.c index 83fd09e..50573ba 100644 --- a/dump.c +++ b/dump.c @@ -461,8 +461,6 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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) diff --git a/embed.fnc b/embed.fnc index 314d134..7665b52 100644 --- a/embed.fnc +++ b/embed.fnc @@ -75,13 +75,6 @@ p |OP* |append_elem |I32 optype|OP* head|OP* tail 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 @@ -968,11 +961,6 @@ Adp |int |nothreadhook 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 @@ -1112,8 +1100,6 @@ s |bool |path_is_absolute|char *name #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 diff --git a/embed.h b/embed.h index 95e7d96..efd0352 100644 --- a/embed.h +++ b/embed.h @@ -37,13 +37,6 @@ #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 @@ -870,10 +863,6 @@ #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 @@ -1001,7 +990,6 @@ #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 @@ -1633,13 +1621,6 @@ #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) @@ -2435,10 +2416,6 @@ #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) @@ -2566,7 +2543,6 @@ #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) diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 80459b4..161bf6b 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -274,7 +274,6 @@ $priv{$_}{128} = "LVINTRO" "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", "IDENT", "SQUASH", "DEL", diff --git a/global.sym b/global.sym index 35e4dfd..825c073 100644 --- a/global.sym +++ b/global.sym @@ -30,13 +30,6 @@ Perl_amagic_call 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 diff --git a/lib/fields.pm b/lib/fields.pm index be2a7ae..a64469c 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -21,10 +21,10 @@ fields - compile-time class fields } } - 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 @@ -51,11 +51,6 @@ hash of the calling package, but this may change in future versions. Do B 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 pragma will combine fields from base classes and any fields declared using the C pragma. This enables field inheritance to work properly. @@ -65,26 +60,21 @@ the class and are not visible to subclasses. Inherited fields can be 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 pragma into the specified class. +fields::new() creates and blesses a restricted-hash comprised of the +fields declared using the C 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 @@ -93,37 +83,14 @@ This makes it possible to write a constructor like this: =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, -L =cut @@ -135,6 +102,8 @@ our(%attr, $VERSION); $VERSION = "1.02"; +use Hash::Util qw(lock_keys); + # some constants sub _PUBLIC () { 1 } sub _PRIVATE () { 2 } @@ -246,40 +215,13 @@ sub _dump # sometimes useful for debugging 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; diff --git a/lib/fields.t b/lib/fields.t index ce57f86..adfe60a 100755 --- a/lib/fields.t +++ b/lib/fields.t @@ -18,6 +18,9 @@ use strict; use warnings; use vars qw($DEBUG); +use Test::More; + + package B1; use fields qw(b1 b2 b3); @@ -25,7 +28,7 @@ package B2; use fields '_b1'; use fields qw(b1 _b2 b2); -sub new { bless [], shift } +sub new { fields::new(shift); } package D1; use base 'B1'; @@ -90,18 +93,16 @@ my %expect = ( '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; @@ -109,37 +110,19 @@ $obj1->{b1} = "B2"; 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(); @@ -147,14 +130,14 @@ print "ok ", ++$testno, "\n"; { 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 @@ -165,10 +148,10 @@ print "ok ", ++$testno, "\n"; 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' ); } @@ -181,8 +164,7 @@ sub VERSION { 42 } 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; @@ -192,8 +174,7 @@ BEGIN { $Has::Version::VERSION = '42' }; 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; @@ -210,29 +191,25 @@ our $eval1 = q{ }; 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' ); diff --git a/lib/overload.pm b/lib/overload.pm index fb1a0d1..99af00f 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -922,10 +922,7 @@ numeric value.) This prints: =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 -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()} }; diff --git a/mg.c b/mg.c index 1c7d239..9e0b4fa 100644 --- a/mg.c +++ b/mg.c @@ -1674,16 +1674,9 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) 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); @@ -1729,16 +1722,9 @@ Perl_vivify_defelem(pTHX_ SV *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)); } diff --git a/op.c b/op.c index 75cff4b..043f0be 100644 --- a/op.c +++ b/op.c @@ -3645,15 +3645,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 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++; @@ -5767,17 +5758,8 @@ Perl_ck_rvconst(pTHX_ register OP *o) 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) @@ -6979,7 +6961,6 @@ void Perl_peep(pTHX_ register OP *o) { register OP* oldop = 0; - STRLEN n_a; if (!o || o->op_seq) return; @@ -7203,11 +7184,8 @@ Perl_peep(pTHX_ register OP *o) 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; @@ -7226,106 +7204,8 @@ Perl_peep(pTHX_ register OP *o) 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++; diff --git a/op.h b/op.h index e60514c..3b1970c 100644 --- a/op.h +++ b/op.h @@ -129,7 +129,6 @@ Deprecated. Use C instead. /* 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. */ diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 8a2e4a4..a0ef21a 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -318,12 +318,6 @@ which is left unnoticed if C uses I system malloc(). (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. - =item Badly placed ()'s (A) You've accidentally run your script through B instead @@ -780,13 +774,6 @@ lexical variable using "my". This is not allowed. If you want to 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, which Perl can't currently @@ -2331,19 +2318,6 @@ this class doesn't exist at this point in your program. 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 diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 564f3b6..3d59479 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1578,9 +1578,6 @@ This surprising autovivification in what does not at first--or even second--glance appear to be an lvalue context may be fixed in a future release. -See L 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. diff --git a/pod/perlref.pod b/pod/perlref.pod index 7255162..7f9b638 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -537,77 +537,8 @@ string is effectively quoted. =head2 Pseudo-hashes: Using an array as a hash -B: This section describes an experimental feature. Details may -change without notice in future versions. - -B: 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 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. - -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 diff --git a/pp.c b/pp.c index d7fc6bf..322e464 100644 --- a/pp.c +++ b/pp.c @@ -3683,11 +3683,10 @@ PP(pp_each) 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); @@ -3698,8 +3697,7 @@ PP(pp_each) 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); } @@ -3739,19 +3737,13 @@ PP(pp_delete) *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"); @@ -3771,8 +3763,6 @@ PP(pp_delete) 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"); @@ -3812,8 +3802,6 @@ PP(pp_exists) 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"); @@ -3826,7 +3814,6 @@ PP(pp_hslice) 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; @@ -3844,45 +3831,36 @@ PP(pp_hslice) && 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; diff --git a/pp_hot.c b/pp_hot.c index 8e36c8a..e204a99 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -798,7 +798,7 @@ PP(pp_rv2hv) 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); @@ -812,7 +812,7 @@ PP(pp_rv2hv) } } 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); @@ -894,8 +894,6 @@ PP(pp_rv2hv) } 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); @@ -907,57 +905,14 @@ PP(pp_rv2hv) } } -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 || @@ -970,26 +925,16 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) 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; } } @@ -1041,19 +986,6 @@ PP(pp_aassign) 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; @@ -1704,11 +1636,6 @@ PP(pp_helem) 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; } diff --git a/proto.h b/proto.h index 2afc6e9..ba900c9 100644 --- a/proto.h +++ b/proto.h @@ -53,13 +53,6 @@ PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail); 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); @@ -1010,11 +1003,6 @@ PERL_CALLCONV int Perl_nothreadhook(pTHX); 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); @@ -1151,7 +1139,6 @@ STATIC bool S_path_is_absolute(pTHX_ char *name); #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); diff --git a/t/op/avhv.t b/t/op/avhv.t index 1ee1da7..d301fad 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -1,5 +1,8 @@ #!./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'; @@ -13,11 +16,25 @@ sub TIEARRAY { bless [], $_[0] } 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, @@ -29,41 +46,68 @@ $sch = { $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; @@ -71,31 +115,47 @@ tie %fake, Tie::StdHash; %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 { @@ -104,81 +164,121 @@ 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($@); diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t index 3db2b46..50c9939 100755 --- a/t/op/hashwarn.t +++ b/t/op/hashwarn.t @@ -66,12 +66,18 @@ my $ref_msg = '/^Reference found where even-sized list expected/'; %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"; -- 1.8.3.1