From 010205895f86f073b0b2a20bd4cfbb05f0134888 Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Thu, 13 Jan 2000 06:49:03 +0000 Subject: [PATCH] support delete() and exists() on array, tied array, and pseudo-hash elements or slices p4raw-id: //depot/perl@4796 --- av.c | 106 ++++++++++++++++++++++++++++++++++++++++++++++-------- embed.h | 12 +++++++ embed.pl | 3 ++ global.sym | 3 ++ lib/Tie/Array.pm | 37 ++++++++++++++++--- lib/Tie/Hash.pm | 2 ++ objXSUB.h | 12 +++++++ op.c | 24 ++++++++++--- perlapi.c | 21 +++++++++++ pod/perldelta.pod | 20 +++++++++++ pod/perlfunc.pod | 74 +++++++++++++++++++++++++------------- pod/perlref.pod | 28 ++++++++++----- pod/perltie.pod | 10 +++--- pp.c | 37 +++++++++++++++---- proto.h | 3 ++ t/op/avhv.t | 23 +++++++++++- t/op/delete.t | 72 ++++++++++++++++++++++++++++++++++--- 17 files changed, 415 insertions(+), 72 deletions(-) diff --git a/av.c b/av.c index 8f3b4f8..3b7e813 100644 --- a/av.c +++ b/av.c @@ -591,6 +591,83 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) (void)av_store(av,fill,&PL_sv_undef); } +SV * +Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) +{ + SV *sv; + + if (!av) + return Nullsv; + if (SvREADONLY(av)) + Perl_croak(aTHX_ PL_no_modify); + if (key < 0) { + key += AvFILL(av) + 1; + if (key < 0) + return Nullsv; + } + if (SvRMAGICAL(av)) { + SV **svp; + if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) + && (svp = av_fetch(av, key, TRUE))) + { + sv = *svp; + mg_clear(sv); + if (mg_find(sv, 'p')) { + sv_unmagic(sv, 'p'); /* No longer an element */ + return sv; + } + return Nullsv; /* element cannot be deleted */ + } + } + if (key > AvFILLp(av)) + return Nullsv; + else { + sv = AvARRAY(av)[key]; + if (key == AvFILLp(av)) { + do { + AvFILLp(av)--; + } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef); + } + else + AvARRAY(av)[key] = &PL_sv_undef; + if (SvSMAGICAL(av)) + mg_set((SV*)av); + } + if (flags & G_DISCARD) { + SvREFCNT_dec(sv); + sv = Nullsv; + } + return sv; +} + +/* + * This relies on the fact that uninitialized array elements + * are set to &PL_sv_undef. + */ + +bool +Perl_av_exists(pTHX_ AV *av, I32 key) +{ + if (!av) + return FALSE; + if (key < 0) { + key += AvFILL(av) + 1; + if (key < 0) + return FALSE; + } + if (SvRMAGICAL(av)) { + if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { + SV *sv = sv_newmortal(); + mg_copy((SV*)av, sv, 0, key); + magic_existspack(sv, mg_find(sv, 'p')); + return SvTRUE(sv); + } + } + if (av_fetch(av, key, 0)) + return TRUE; + 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 @@ -638,34 +715,33 @@ Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash) return av_fetch(av, avhv_index_sv(HeVAL(he)), 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. * - * This relies on the fact that uninitialized array elements - * are set to &PL_sv_undef. */ bool Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash) { HV *keys = avhv_keys(av); HE *he; - IV ix; he = hv_fetch_ent(keys, keysv, FALSE, hash); if (!he || !SvOK(HeVAL(he))) return FALSE; - ix = SvIV(HeVAL(he)); - - /* If the array hasn't been extended to reach the key yet then - * it hasn't been accessed and thus does not exist. We use - * AvFILL() rather than AvFILLp() to handle tied av. */ - if (ix > 0 && ix <= AvFILL(av) - && (SvRMAGICAL(av) - || (AvARRAY(av)[ix] && AvARRAY(av)[ix] != &PL_sv_undef))) - { - return TRUE; - } - return FALSE; + return av_exists(av, avhv_index_sv(HeVAL(he))); } HE * diff --git a/embed.h b/embed.h index 3b5c0bf..27685ff 100644 --- a/embed.h +++ b/embed.h @@ -67,12 +67,15 @@ #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply +#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_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 av_extend Perl_av_extend #define av_fake Perl_av_fake #define av_fetch Perl_av_fetch @@ -1502,12 +1505,15 @@ #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #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 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_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 av_extend(a,b) Perl_av_extend(aTHX_ a,b) #define av_fake(a,b) Perl_av_fake(aTHX_ a,b) #define av_fetch(a,b,c) Perl_av_fetch(aTHX_ a,b,c) @@ -2919,6 +2925,8 @@ #define append_list Perl_append_list #define Perl_apply CPerlObj::Perl_apply #define apply Perl_apply +#define Perl_avhv_delete_ent CPerlObj::Perl_avhv_delete_ent +#define avhv_delete_ent Perl_avhv_delete_ent #define Perl_avhv_exists_ent CPerlObj::Perl_avhv_exists_ent #define avhv_exists_ent Perl_avhv_exists_ent #define Perl_avhv_fetch_ent CPerlObj::Perl_avhv_fetch_ent @@ -2931,6 +2939,10 @@ #define avhv_keys Perl_avhv_keys #define Perl_av_clear CPerlObj::Perl_av_clear #define av_clear Perl_av_clear +#define Perl_av_delete CPerlObj::Perl_av_delete +#define av_delete Perl_av_delete +#define Perl_av_exists CPerlObj::Perl_av_exists +#define av_exists Perl_av_exists #define Perl_av_extend CPerlObj::Perl_av_extend #define av_extend Perl_av_extend #define Perl_av_fake CPerlObj::Perl_av_fake diff --git a/embed.pl b/embed.pl index 2265901..84d689e 100755 --- a/embed.pl +++ b/embed.pl @@ -1084,12 +1084,15 @@ p |bool |Gv_AMupdate |HV* stash 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 +p |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash p |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash p |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash p |HE* |avhv_iternext |AV *ar p |SV* |avhv_iterval |AV *ar|HE* entry p |HV* |avhv_keys |AV *ar p |void |av_clear |AV* ar +p |SV* |av_delete |AV* ar|I32 key|I32 flags +p |bool |av_exists |AV* ar|I32 key p |void |av_extend |AV* ar|I32 key p |AV* |av_fake |I32 size|SV** svp p |SV** |av_fetch |AV* ar|I32 key|I32 lval diff --git a/global.sym b/global.sym index 4199328..0fc9739 100644 --- a/global.sym +++ b/global.sym @@ -23,12 +23,15 @@ Perl_Gv_AMupdate Perl_append_elem Perl_append_list Perl_apply +Perl_avhv_delete_ent Perl_avhv_exists_ent Perl_avhv_fetch_ent Perl_avhv_iternext Perl_avhv_iterval Perl_avhv_keys Perl_av_clear +Perl_av_delete +Perl_av_exists Perl_av_extend Perl_av_fake Perl_av_fetch diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index 3f34c3b..5ef83c4 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -1,7 +1,8 @@ package Tie::Array; use vars qw($VERSION); use strict; -$VERSION = '1.00'; +use Carp; +$VERSION = '1.01'; # Pod documentation after __END__ below. @@ -74,6 +75,16 @@ sub SPLICE return @result; } +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg dosn't define an EXISTS method"; +} + +sub DELETE { + my $pkg = ref $_[0]; + croak "$pkg dosn't define a DELETE method"; +} + package Tie::StdArray; use vars qw(@ISA); @ISA = 'Tie::Array'; @@ -88,6 +99,8 @@ sub POP { pop(@{$_[0]}) } sub PUSH { my $o = shift; push(@$o,@_) } sub SHIFT { shift(@{$_[0]}) } sub UNSHIFT { my $o = shift; unshift(@$o,@_) } +sub EXISTS { exists $_[0]->[$_[1]] } +sub DELETE { delete $_[0]->[$_[1]] } sub SPLICE { @@ -120,6 +133,8 @@ Tie::Array - base class for tied arrays sub STORE { ... } # mandatory if elements writeable sub STORESIZE { ... } # mandatory if elements can be added/deleted + sub EXISTS { ... } # mandatory if exists() expected to work + sub DELETE { ... } # mandatory if delete() expected to work # optional methods - for efficiency sub CLEAR { ... } @@ -150,9 +165,11 @@ Tie::Array - base class for tied arrays This module provides methods for array-tying classes. See L for a list of the functions required in order to tie an array -to a package. The basic B package provides stub C -and C methods, and implementations of C, C, C, -C, C and C in terms of basic C, C, +to a package. The basic B package provides stub C, +and C methods that do nothing, stub C and C +methods that croak() if the delete() or exists() builtins are ever called +on the tied array, and implementations of C, C, C, +C, C and C in terms of basic C, C, C, C. The B package provides efficient methods required for tied arrays @@ -203,6 +220,18 @@ deleted. Informative call that array is likely to grow to have I entries. Can be used to optimize allocation. This method need do nothing. +=item EXISTS this, key + +Verify that the element at index I exists in the tied array I. + +The B implementation is a stub that simply croaks. + +=item DELETE this, key + +Delete the element at index I from the tied array I. + +The B implementation is a stub that simply croaks. + =item CLEAR this Clear (remove, delete, ...) all values from the tied array associated with diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 2902efb..928b798 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -73,6 +73,8 @@ Return the next key for the hash. Verify that I exists with the tied hash I. +The B implementation is a stub that simply croaks. + =item DELETE this, key Delete the key I from the tied hash I. diff --git a/objXSUB.h b/objXSUB.h index 56895c5..035367d 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -851,6 +851,10 @@ #define Perl_apply pPerl->Perl_apply #undef apply #define apply Perl_apply +#undef Perl_avhv_delete_ent +#define Perl_avhv_delete_ent pPerl->Perl_avhv_delete_ent +#undef avhv_delete_ent +#define avhv_delete_ent Perl_avhv_delete_ent #undef Perl_avhv_exists_ent #define Perl_avhv_exists_ent pPerl->Perl_avhv_exists_ent #undef avhv_exists_ent @@ -875,6 +879,14 @@ #define Perl_av_clear pPerl->Perl_av_clear #undef av_clear #define av_clear Perl_av_clear +#undef Perl_av_delete +#define Perl_av_delete pPerl->Perl_av_delete +#undef av_delete +#define av_delete Perl_av_delete +#undef Perl_av_exists +#define Perl_av_exists pPerl->Perl_av_exists +#undef av_exists +#define av_exists Perl_av_exists #undef Perl_av_extend #define Perl_av_extend pPerl->Perl_av_extend #undef av_extend diff --git a/op.c b/op.c index 383e917..805aeaa 100644 --- a/op.c +++ b/op.c @@ -4921,11 +4921,22 @@ Perl_ck_delete(pTHX_ OP *o) o->op_private = 0; if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type == OP_HSLICE) + switch (kid->op_type) { + case OP_ASLICE: + o->op_flags |= OPf_SPECIAL; + /* FALL THROUGH */ + case OP_HSLICE: o->op_private |= OPpSLICE; - else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH element or slice", + break; + case OP_AELEM: + o->op_flags |= OPf_SPECIAL; + /* FALL THROUGH */ + case OP_HELEM: + break; + default: + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", PL_op_desc[o->op_type]); + } null(kid); } return o; @@ -5011,8 +5022,11 @@ Perl_ck_exists(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH element", PL_op_desc[o->op_type]); + if (kid->op_type == OP_AELEM) + o->op_flags |= OPf_SPECIAL; + else if (kid->op_type != OP_HELEM) + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", + PL_op_desc[o->op_type]); null(kid); } return o; diff --git a/perlapi.c b/perlapi.c index d0f8a4f..589d8b6 100644 --- a/perlapi.c +++ b/perlapi.c @@ -91,6 +91,13 @@ Perl_apply(pTHXo_ I32 type, SV** mark, SV** sp) return ((CPerlObj*)pPerl)->Perl_apply(type, mark, sp); } +#undef Perl_avhv_delete_ent +SV* +Perl_avhv_delete_ent(pTHXo_ AV *ar, SV* keysv, I32 flags, U32 hash) +{ + return ((CPerlObj*)pPerl)->Perl_avhv_delete_ent(ar, keysv, flags, hash); +} + #undef Perl_avhv_exists_ent bool Perl_avhv_exists_ent(pTHXo_ AV *ar, SV* keysv, U32 hash) @@ -133,6 +140,20 @@ Perl_av_clear(pTHXo_ AV* ar) ((CPerlObj*)pPerl)->Perl_av_clear(ar); } +#undef Perl_av_delete +SV* +Perl_av_delete(pTHXo_ AV* ar, I32 key, I32 flags) +{ + return ((CPerlObj*)pPerl)->Perl_av_delete(ar, key, flags); +} + +#undef Perl_av_exists +bool +Perl_av_exists(pTHXo_ AV* ar, I32 key) +{ + return ((CPerlObj*)pPerl)->Perl_av_exists(ar, key); +} + #undef Perl_av_extend void Perl_av_extend(pTHXo_ AV* ar, I32 key) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 47f7c26..b205c74 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -425,6 +425,22 @@ This is rather similar to how the arrow may be omitted from C<$foo[10]->{'foo'}>. Note however, that the arrow is still required for C('bar')>. +=head2 exists() and delete() are supported on array elements + +The exists() and delete() builtins now work on simple arrays as well. +The behavior is similar to that on hash elements. + +exists() can be used to check whether an array element exists without +autovivifying it. If the array is tied, the EXISTS() method in the +corresponding tied package will be invoked. + +delete() may now be used to remove an element from the array and return +it. If the element happens to be the one at the end, the size of the +array also shrinks by one. If the array is tied, the DELETE() method +in the corresponding tied package will be invoked. + +See L and L for examples. + =head2 syswrite() ease-of-use The length argument of C has become optional. @@ -812,6 +828,10 @@ been corrected. When applied to a pseudo-hash element, exists() now reports whether the specified value exists, not merely if the key is valid. +delete() now works on pseudo-hashes. When given a pseudo-hash element +or slice it deletes the values corresponding to the keys (but not the keys +themselves). See L. + =head2 C and AUTOLOAD The C construct works correctly when C<&sub> happens diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 8928df1..161ebaa 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -925,35 +925,52 @@ See also L, L, L. =item delete EXPR -Deletes the specified key(s) and their associated values from a hash. -For each key, returns the deleted value associated with that key, or -the undefined value if there was no such key. Deleting from C<$ENV{}> -modifies the environment. Deleting from a hash tied to a DBM file -deletes the entry from the DBM file. (But deleting from a Cd hash -doesn't necessarily return anything.) +Given an expression that specifies a hash element, array element, hash slice, +or array slice, deletes the specified element(s) from the hash or array. +If the array elements happen to be at the end of the array, the size +of the array will shrink by that number of elements. -The following deletes all the values of a hash: +Returns each element so deleted or the undefined value if there was no such +element. Deleting from C<$ENV{}> modifies the environment. Deleting from +a hash tied to a DBM file deletes the entry from the DBM file. Deleting +from a Cd hash or array may not necessarily return anything. + +The following (inefficiently) deletes all the values of %HASH and @ARRAY: foreach $key (keys %HASH) { delete $HASH{$key}; } -And so does this: + foreach $index (0 .. $#ARRAY) { + delete $ARRAY[$index]; + } + +And so do these: - delete @HASH{keys %HASH} + delete @HASH{keys %HASH}; + + delete @ARRAY{0 .. $#ARRAY}; But both of these are slower than just assigning the empty list -or undefining it: +or undefining %HASH or @ARRAY: + + %HASH = (); # completely empty %HASH + undef %HASH; # forget %HASH ever existed - %hash = (); # completely empty %hash - undef %hash; # forget %hash every existed + @ARRAY = (); # completely empty @ARRAY + undef @ARRAY; # forget @ARRAY ever existed Note that the EXPR can be arbitrarily complicated as long as the final -operation is a hash element lookup or hash slice: +operation is a hash element, array element, hash slice, or array slice +lookup: delete $ref->[$x][$y]{$key}; delete @{$ref->[$x][$y]}{$key1, $key2, @morekeys}; + delete $ref->[$x][$y][$index]; + delete @{$ref->[$x][$y]}[$index1, $index2, @moreindices]; + + =item die LIST Outside an C, prints the value of LIST to C and @@ -1386,27 +1403,36 @@ any C methods in your objects. =item exists EXPR -Returns true if the specified hash key exists in its hash, even -if the corresponding value is undefined. +Given an expression that specifies a hash element or array element, +returns true if the specified element exists in the hash or array, +even if the corresponding value is undefined. The element is not +autovivified if it doesn't exist. - print "Exists\n" if exists $array{$key}; - print "Defined\n" if defined $array{$key}; - print "True\n" if $array{$key}; + print "Exists\n" if exists $hash{$key}; + print "Defined\n" if defined $hash{$key}; + print "True\n" if $hash{$key}; + + print "Exists\n" if exists $array[$index]; + print "Defined\n" if defined $array[$index]; + print "True\n" if $array[$index]; A hash element can be true only if it's defined, and defined if it exists, but the reverse doesn't necessarily hold true. Note that the EXPR can be arbitrarily complicated as long as the final -operation is a hash key lookup: +operation is a hash or array key lookup: if (exists $ref->{A}->{B}->{$key}) { } if (exists $hash{A}{B}{$key}) { } -Although the last element will not spring into existence just because -its existence was tested, intervening ones will. Thus C<$ref-E{"A"}> -and C<$ref-E{"A"}-E{"B"}> will spring into existence due to the -existence test for a $key element. This happens anywhere the arrow -operator is used, including even + if (exists $ref->{A}->{B}->[$ix]) { } + if (exists $hash{A}{B}[$ix]) { } + +Although the deepest nested array or hash will not spring into existence +just because its existence was tested, any intervening ones will. +Thus C<$ref-E{"A"}> and C<$ref-E{"A"}-E{"B"}> will spring +into existence due to the existence test for the $key element above. +This happens anywhere the arrow operator is used, including even: undef $ref; if (exists $ref->{"Some key"}) { } diff --git a/pod/perlref.pod b/pod/perlref.pod index 12bc581..f738399 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -558,29 +558,39 @@ to array indices. Here is an example: print "$k => $v\n"; } -Perl will raise an exception if you try to delete keys from a pseudo-hash -or try to access nonexistent fields. For better performance, Perl can also +Perl will raise an exception if you try to access nonexistent fields. +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 existance of a key in a +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 been used yet. It acts this way to match the behavior +given field has ever been set. It acts this way to match the behavior of a regular hash. For instance: $phash = [{foo =>1, bar => 2, pants => 3}, 'FOO']; $phash->{pants} = undef; - exists $phash->{foo}; # true, 'foo' was set in the declaration - exists $phash->{bar}; # false, 'bar' has not been used. - exists $phash->{pants}; # true, your 'pants' have been touched + 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. - exists $phash->[0]{bar}; # true, 'bar' is a valid field - exists $phash->[0]{shoes}; # false, 'shoes' can't be used + 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 =head2 Function Templates diff --git a/pod/perltie.pod b/pod/perltie.pod index 5611174..58e9c43 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -185,10 +185,12 @@ methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps DESTROY. FETCHSIZE and STORESIZE are used to provide C<$#array> and equivalent C access. -The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE are required if the perl -operator with the corresponding (but lowercase) name is to operate on the -tied array. The B class can be used as a base class to implement -these in terms of the basic five methods above. +The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE, DELETE, and EXISTS are +required if the perl operator with the corresponding (but lowercase) name +is to operate on the tied array. The B class can be used as a +base class to implement the first five of these in terms of the basic +methods above. The default implementations of DELETE and EXISTS in +B simply C. In addition EXTEND will be called when perl would have pre-extended allocation in a real array. diff --git a/pp.c b/pp.c index 7fc6b1a..c387433 100644 --- a/pp.c +++ b/pp.c @@ -2647,13 +2647,28 @@ PP(pp_delete) U32 hvtype; hv = (HV*)POPs; hvtype = SvTYPE(hv); - while (++MARK <= SP) { - if (hvtype == SVt_PVHV) + if (hvtype == SVt_PVHV) { /* hash element */ + while (++MARK <= SP) { sv = hv_delete_ent(hv, *MARK, discard, 0); - else - DIE(aTHX_ "Not a HASH reference"); - *MARK = sv ? sv : &PL_sv_undef; + *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 + DIE(aTHX_ "Not a HASH reference"); if (discard) SP = ORIGMARK; else if (gimme == G_SCALAR) { @@ -2667,6 +2682,12 @@ PP(pp_delete) hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); + 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 (!sv) @@ -2687,7 +2708,11 @@ PP(pp_exists) RETPUSHYES; } else if (SvTYPE(hv) == SVt_PVAV) { - if (avhv_exists_ent((AV*)hv, tmpsv, 0)) + if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ + if (av_exists((AV*)hv, SvIV(tmpsv))) + RETPUSHYES; + } + else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ RETPUSHYES; } else { diff --git a/proto.h b/proto.h index 4b991f8..36f4a40 100644 --- a/proto.h +++ b/proto.h @@ -59,12 +59,15 @@ PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash); 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 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 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); PERL_CALLCONV void Perl_av_extend(pTHX_ AV* ar, I32 key); PERL_CALLCONV AV* Perl_av_fake(pTHX_ I32 size, SV** svp); PERL_CALLCONV SV** Perl_av_fetch(pTHX_ AV* ar, I32 key, I32 lval); diff --git a/t/op/avhv.t b/t/op/avhv.t index 92afa37..23f9c69 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..15\n"; +print "1..20\n"; $sch = { 'abc' => 1, @@ -118,3 +118,24 @@ print "not " unless exists $avhv->{pants}; print "ok 14\n"; print "not " if exists $avhv->{bar}; print "ok 15\n"; + +$avhv->{bar} = 10; +print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; +print "ok 16\n"; + +$v = delete $avhv->{bar}; +print "not " unless $v == 10; +print "ok 17\n"; + +print "not " if exists $avhv->{bar}; +print "ok 18\n"; + +$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"; + +print "not " unless "$avhv->{bar}" eq "yyy"; +print "ok 20\n"; diff --git a/t/op/delete.t b/t/op/delete.t index 6452c35..10a218b 100755 --- a/t/op/delete.t +++ b/t/op/delete.t @@ -1,6 +1,8 @@ #!./perl -print "1..17\n"; +print "1..36\n"; + +# delete() on hash elements $foo{1} = 'a'; $foo{2} = 'b'; @@ -11,7 +13,7 @@ $foo{5} = 'e'; $foo = delete $foo{2}; if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} -if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} +unless (exists $foo{2}) {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";} @@ -22,8 +24,8 @@ if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";} if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";} if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";} if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";} -if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} -if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} +unless (exists $foo{4}) {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +unless (exists $foo{5}) {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";} if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";} @@ -57,3 +59,65 @@ print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n"; print "not " unless $a == $b && $b == $c; print "ok 17\n"; } + +# delete() on array elements + +@foo = (); +$foo[1] = 'a'; +$foo[2] = 'b'; +$foo[3] = 'c'; +$foo[4] = 'd'; +$foo[5] = 'e'; + +$foo = delete $foo[2]; + +if ($foo eq 'b') {print "ok 18\n";} else {print "not ok 18 $foo\n";} +unless (exists $foo[2]) {print "ok 19\n";} else {print "not ok 19 $foo[2]\n";} +if ($foo[1] eq 'a') {print "ok 20\n";} else {print "not ok 20\n";} +if ($foo[3] eq 'c') {print "ok 21\n";} else {print "not ok 21\n";} +if ($foo[4] eq 'd') {print "ok 22\n";} else {print "not ok 22\n";} +if ($foo[5] eq 'e') {print "ok 23\n";} else {print "not ok 23\n";} + +@bar = delete @foo[4,5]; + +if (@bar == 2) {print "ok 24\n";} else {print "not ok 24 ", @bar+0, "\n";} +if ($bar[0] eq 'd') {print "ok 25\n";} else {print "not ok 25 ", $bar[0], "\n";} +if ($bar[1] eq 'e') {print "ok 26\n";} else {print "not ok 26 ", $bar[1], "\n";} +unless (exists $foo[4]) {print "ok 27\n";} else {print "not ok 27 $foo[4]\n";} +unless (exists $foo[5]) {print "ok 28\n";} else {print "not ok 28 $foo[5]\n";} +if ($foo[1] eq 'a') {print "ok 29\n";} else {print "not ok 29\n";} +if ($foo[3] eq 'c') {print "ok 30\n";} else {print "not ok 30\n";} + +$foo = join('',@foo); +if ($foo eq 'ac') {print "ok 31\n";} else {print "not ok 31\n";} + +if (@foo == 4) {print "ok 32\n";} else {print "not ok 32\n";} + +foreach $key (0 .. $#foo) { + delete $foo[$key]; +} + +if (@foo == 0) {print "ok 33\n";} else {print "not ok 33\n";} + +$foo[0] = 'x'; +$foo[1] = 'y'; + +$foo = "@foo"; +print +($foo eq 'x y') ? "ok 34\n" : "not ok 34\n"; + +$refary[0]->[0] = "FOO"; +$refary[0]->[3] = "BAR"; + +delete $refary[0]->[3]; + +print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n"; + +{ + my @a = 33; + my($a) = \(@a); + my $b = \$a[0]; + my $c = \delete $a[bar]; + + print "not " unless $a == $b && $b == $c; + print "ok 36\n"; +} -- 2.7.4