(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
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 *
#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
#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)
#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
#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
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
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
package Tie::Array;
use vars qw($VERSION);
use strict;
-$VERSION = '1.00';
+use Carp;
+$VERSION = '1.01';
# Pod documentation after __END__ below.
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';
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
{
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 { ... }
This module provides methods for array-tying classes. See
L<perltie> for a list of the functions required in order to tie an array
-to a package. The basic B<Tie::Array> package provides stub C<DELETE>
-and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
-C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
+to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
+and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
+methods that croak() if the delete() or exists() builtins are ever called
+on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
+C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
C<FETCHSIZE>, C<STORESIZE>.
The B<Tie::StdArray> package provides efficient methods required for tied arrays
Informative call that array is likely to grow to have I<count> entries.
Can be used to optimize allocation. This method need do nothing.
+=item EXISTS this, key
+
+Verify that the element at index I<key> exists in the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
+=item DELETE this, key
+
+Delete the element at index I<key> from the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
=item CLEAR this
Clear (remove, delete, ...) all values from the tied array associated with
Verify that I<key> exists with the tied hash I<this>.
+The B<Tie::Hash> implementation is a stub that simply croaks.
+
=item DELETE this, key
Delete the key I<key> from the tied hash I<this>.
#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
#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
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;
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;
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)
((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)
C<$foo[10]->{'foo'}>. Note however, that the arrow is still
required for C<foo(10)->('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<perlfunc/exists> and L<perlfunc/delete> for examples.
+
=head2 syswrite() ease-of-use
The length argument of C<syswrite()> has become optional.
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<perlref/"Pseudo-hashes: Using an array as a hash">.
+
=head2 C<goto &sub> and AUTOLOAD
The C<goto &sub> construct works correctly when C<&sub> happens
=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 C<tie>d 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 C<tie>d 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<eval>, prints the value of LIST to C<STDERR> and
=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<gt>{"A"}>
-and C<$ref-E<gt>{"A"}-E<gt>{"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<gt>{"A"}> and C<$ref-E<gt>{"A"}-E<gt>{"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"}) { }
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<fields>.
-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
FETCHSIZE and STORESIZE are used to provide C<$#array> and
equivalent C<scalar(@array)> 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<Tie::Array> 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<Tie::Array> 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<Tie::Array> simply C<croak>.
In addition EXTEND will be called when perl would have pre-extended
allocation in a real array.
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) {
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)
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 {
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);
package main;
-print "1..15\n";
+print "1..20\n";
$sch = {
'abc' => 1,
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";
#!./perl
-print "1..17\n";
+print "1..36\n";
+
+# delete() on hash elements
$foo{1} = 'a';
$foo{2} = 'b';
$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";}
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";}
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";
+}
projects / platform / upstream / perl.git / commitdiff