In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f9a83b002447a32d10950dbf65a6f1c4e13eadcc?hp=1d5727c1fd186772fdf2e7e5f94d3656809073d6>
- Log ----------------------------------------------------------------- commit f9a83b002447a32d10950dbf65a6f1c4e13eadcc Merge: 1d5727c... d361faf... Author: Vincent Pit <[email protected]> Date: Wed Jul 29 20:38:07 2009 +0200 Merge branch 'deletelocal' into blead ----------------------------------------------------------------------- Summary of changes: embed.fnc | 5 +- embed.h | 8 ++- global.sym | 3 +- op.c | 2 + op.h | 1 + pod/perlfunc.pod | 8 ++ pod/perlsub.pod | 50 +++++++++++++ pp.c | 203 ++++++++++++++++++++++++++++++++++++++++++++++++++---- pp_hot.c | 15 ++--- proto.h | 15 ++++- scope.c | 36 ++++++++-- scope.h | 4 + t/op/local.t | 185 +++++++++++++++++++++++++++++++++++++++++++++++++- 13 files changed, 499 insertions(+), 36 deletions(-) diff --git a/embed.fnc b/embed.fnc index f727f00..deff9ad 100644 --- a/embed.fnc +++ b/embed.fnc @@ -883,13 +883,15 @@ Apda |char* |savesharedpvn |NN const char *const pv|const STRLEN len Apda |char* |savesvpv |NN SV* sv Ap |void |savestack_grow Ap |void |savestack_grow_cnt |I32 need -Ap |void |save_aelem |NN AV* av|I32 idx|NN SV **sptr +Amp |void |save_aelem |NN AV* av|I32 idx|NN SV **sptr +Ap |void |save_aelem_flags|NN AV* av|I32 idx|NN SV **sptr|const U32 flags Ap |I32 |save_alloc |I32 size|I32 pad Ap |void |save_aptr |NN AV** aptr Ap |AV* |save_ary |NN GV* gv Ap |void |save_bool |NN bool* boolp Ap |void |save_clearsv |NN SV** svp Ap |void |save_delete |NN HV *hv|NN char *key|I32 klen +Ap |void |save_hdelete |NN HV *hv|NN SV *keysv Ap |void |save_adelete |NN AV *av|I32 key Ap |void |save_destructor|DESTRUCTORFUNC_NOCONTEXT_t f|NN void* p Ap |void |save_destructor_x|DESTRUCTORFUNC_t f|NULLOK void* p @@ -1500,6 +1502,7 @@ s |SV * |incpush_if_exists|NN AV *const av|NN SV *dir|NN SV *const stem #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) +s |OP* |do_delete_local sR |SV* |refto |NN SV* sv #endif #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) diff --git a/embed.h b/embed.h index 93dfa74..0847c63 100644 --- a/embed.h +++ b/embed.h @@ -771,13 +771,14 @@ #define savesvpv Perl_savesvpv #define savestack_grow Perl_savestack_grow #define savestack_grow_cnt Perl_savestack_grow_cnt -#define save_aelem Perl_save_aelem +#define save_aelem_flags Perl_save_aelem_flags #define save_alloc Perl_save_alloc #define save_aptr Perl_save_aptr #define save_ary Perl_save_ary #define save_bool Perl_save_bool #define save_clearsv Perl_save_clearsv #define save_delete Perl_save_delete +#define save_hdelete Perl_save_hdelete #define save_adelete Perl_save_adelete #define save_destructor Perl_save_destructor #define save_destructor_x Perl_save_destructor_x @@ -1312,6 +1313,7 @@ #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE +#define do_delete_local S_do_delete_local #define refto S_refto #endif #endif @@ -3106,13 +3108,14 @@ #define savesvpv(a) Perl_savesvpv(aTHX_ a) #define savestack_grow() Perl_savestack_grow(aTHX) #define savestack_grow_cnt(a) Perl_savestack_grow_cnt(aTHX_ a) -#define save_aelem(a,b,c) Perl_save_aelem(aTHX_ a,b,c) +#define save_aelem_flags(a,b,c,d) Perl_save_aelem_flags(aTHX_ a,b,c,d) #define save_alloc(a,b) Perl_save_alloc(aTHX_ a,b) #define save_aptr(a) Perl_save_aptr(aTHX_ a) #define save_ary(a) Perl_save_ary(aTHX_ a) #define save_bool(a) Perl_save_bool(aTHX_ a) #define save_clearsv(a) Perl_save_clearsv(aTHX_ a) #define save_delete(a,b,c) Perl_save_delete(aTHX_ a,b,c) +#define save_hdelete(a,b) Perl_save_hdelete(aTHX_ a,b) #define save_adelete(a,b) Perl_save_adelete(aTHX_ a,b) #define save_destructor(a,b) Perl_save_destructor(aTHX_ a,b) #define save_destructor_x(a,b) Perl_save_destructor_x(aTHX_ a,b) @@ -3654,6 +3657,7 @@ #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE +#define do_delete_local() S_do_delete_local(aTHX) #define refto(a) S_refto(aTHX_ a) #endif #endif diff --git a/global.sym b/global.sym index 474e6bb..de14a7b 100644 --- a/global.sym +++ b/global.sym @@ -433,13 +433,14 @@ Perl_savesharedpvn Perl_savesvpv Perl_savestack_grow Perl_savestack_grow_cnt -Perl_save_aelem +Perl_save_aelem_flags Perl_save_alloc Perl_save_aptr Perl_save_ary Perl_save_bool Perl_save_clearsv Perl_save_delete +Perl_save_hdelete Perl_save_adelete Perl_save_destructor Perl_save_destructor_x diff --git a/op.c b/op.c index d7ef32c..d1ed080 100644 --- a/op.c +++ b/op.c @@ -6463,6 +6463,8 @@ Perl_ck_delete(pTHX_ OP *o) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", OP_DESC(o)); } + if (kid->op_private & OPpLVAL_INTRO) + o->op_private |= OPpLVAL_INTRO; op_null(kid); } return o; diff --git a/op.h b/op.h index f06dbdc..e8ba8ef 100644 --- a/op.h +++ b/op.h @@ -244,6 +244,7 @@ Deprecated. Use C<GIMME_V> instead. /* Private for OP_DELETE */ #define OPpSLICE 64 /* Operating on a list of keys */ +/* Also OPpLVAL_INTRO (128) */ /* Private for OP_EXISTS */ #define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */ diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 23e5535..3a345aa 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1234,6 +1234,10 @@ lookup: delete $ref->[$x][$y][$index]; delete @{$ref->[$x][$y]}[$index1, $index2, @moreindices]; +The C<delete local EXPR> construct can also be used to localize the deletion +of array/hash elements to the current block. +See L<perlsub/"Localized deletion of elements of composite types">. + =item die LIST X<die> X<throw> X<exception> X<raise> X<$@> X<abort> @@ -2736,6 +2740,10 @@ block, file, or eval. If more than one value is listed, the list must be placed in parentheses. See L<perlsub/"Temporary Values via local()"> for details, including issues with tied arrays and hashes. +The C<delete local EXPR> construct can also be used to localize the deletion +of array/hash elements to the current block. +See L<perlsub/"Localized deletion of elements of composite types">. + =item localtime EXPR X<localtime> X<ctime> diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 74d0b1a..325c823 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -535,6 +535,7 @@ Synopsis: local @oof = @bar; # make @oof dynamic, and init it local $hash{key} = "val"; # sets a local value for this hash entry + delete local $hash{key}; # delete this entry for the current block local ($cond ? $v1 : $v2); # several types of lvalues support # localization @@ -692,6 +693,55 @@ Perl will print The behavior of local() on non-existent members of composite types is subject to change in future. +=head3 Localized deletion of elements of composite types +X<delete> X<local, composite type element> X<local, array element> X<local, hash element> + +You can use the C<delete local $array[$idx]> and C<delete local $hash{key}> +constructs to delete a composite type entry for the current block and restore +it when it ends. They return the array/hash value before the localization, +which means that they are respectively equivalent to + + do { + my $val = $array[$idx]; + local $array[$idx]; + delete $array[$idx]; + $val + } + +and + + do { + my $val = $hash{key}; + local $hash{key}; + delete $hash{key}; + $val + } + +except that for those the C<local> is scoped to the C<do> block. Slices are +also accepted. + + my %hash = ( + a => [ 7, 8, 9 ], + b => 1, + ) + + { + my $a = delete local $hash{a}; + # $a is [ 7, 8, 9 ] + # %hash is (b => 1) + + { + my @nums = delete local @$a[0, 2] + # @nums is (7, 9) + # $a is [ undef, 8 ] + + $a[0] = 999; # will be erased when the scope ends + } + # $a is back to [ 7, 8, 9 ] + + } + # %hash is back to its original state + =head2 Lvalue subroutines X<lvalue> X<subroutine, lvalue> diff --git a/pp.c b/pp.c index 9cedc3f..930bc53 100644 --- a/pp.c +++ b/pp.c @@ -4066,12 +4066,195 @@ PP(pp_each) RETURN; } -PP(pp_delete) +STATIC OP * +S_do_delete_local(pTHX) { dVAR; dSP; const I32 gimme = GIMME_V; - const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; + const MAGIC *mg; + HV *stash; + + if (PL_op->op_private & OPpSLICE) { + dMARK; dORIGMARK; + SV * const osv = POPs; + const bool tied = SvRMAGICAL(osv) + && mg_find((const SV *)osv, PERL_MAGIC_tied); + const bool can_preserve = SvCANEXISTDELETE(osv) + || mg_find((const SV *)osv, PERL_MAGIC_env); + const U32 type = SvTYPE(osv); + if (type == SVt_PVHV) { /* hash element */ + HV * const hv = MUTABLE_HV(osv); + while (++MARK <= SP) { + SV * const keysv = *MARK; + SV *sv = NULL; + bool preeminent = TRUE; + if (can_preserve) + preeminent = hv_exists_ent(hv, keysv, 0); + if (tied) { + HE *he = hv_fetch_ent(hv, keysv, 1, 0); + if (he) + sv = HeVAL(he); + else + preeminent = FALSE; + } + else { + sv = hv_delete_ent(hv, keysv, 0, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + *MARK = sv_mortalcopy(sv); + mg_clear(sv); + } else + *MARK = sv; + } + else { + SAVEHDELETE(hv, keysv); + *MARK = &PL_sv_undef; + } + } + } + else if (type == SVt_PVAV) { /* array element */ + if (PL_op->op_flags & OPf_SPECIAL) { + AV * const av = MUTABLE_AV(osv); + while (++MARK <= SP) { + I32 idx = SvIV(*MARK); + SV *sv = NULL; + bool preeminent = TRUE; + if (can_preserve) + preeminent = av_exists(av, idx); + if (tied) { + SV **svp = av_fetch(av, idx, 1); + if (svp) + sv = *svp; + else + preeminent = FALSE; + } + else { + sv = av_delete(av, idx, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + *MARK = sv_mortalcopy(sv); + mg_clear(sv); + } else + *MARK = sv; + } + else { + SAVEADELETE(av, idx); + *MARK = &PL_sv_undef; + } + } + } + } + else + DIE(aTHX_ "Not a HASH reference"); + if (gimme == G_VOID) + SP = ORIGMARK; + else if (gimme == G_SCALAR) { + MARK = ORIGMARK; + if (SP > MARK) + *++MARK = *SP; + else + *++MARK = &PL_sv_undef; + SP = MARK; + } + } + else { + SV * const keysv = POPs; + SV * const osv = POPs; + const bool tied = SvRMAGICAL(osv) + && mg_find((const SV *)osv, PERL_MAGIC_tied); + const bool can_preserve = SvCANEXISTDELETE(osv) + || mg_find((const SV *)osv, PERL_MAGIC_env); + const U32 type = SvTYPE(osv); + SV *sv = NULL; + if (type == SVt_PVHV) { + HV * const hv = MUTABLE_HV(osv); + bool preeminent = TRUE; + if (can_preserve) + preeminent = hv_exists_ent(hv, keysv, 0); + if (tied) { + HE *he = hv_fetch_ent(hv, keysv, 1, 0); + if (he) + sv = HeVAL(he); + else + preeminent = FALSE; + } + else { + sv = hv_delete_ent(hv, keysv, 0, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + SV *nsv = sv_mortalcopy(sv); + mg_clear(sv); + sv = nsv; + } + } + else + SAVEHDELETE(hv, keysv); + } + else if (type == SVt_PVAV) { + if (PL_op->op_flags & OPf_SPECIAL) { + AV * const av = MUTABLE_AV(osv); + I32 idx = SvIV(keysv); + bool preeminent = TRUE; + if (can_preserve) + preeminent = av_exists(av, idx); + if (tied) { + SV **svp = av_fetch(av, idx, 1); + if (svp) + sv = *svp; + else + preeminent = FALSE; + } + else { + sv = av_delete(av, idx, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + SV *nsv = sv_mortalcopy(sv); + mg_clear(sv); + sv = nsv; + } + } + else + SAVEADELETE(av, idx); + } + else + DIE(aTHX_ "panic: avhv_delete no longer supported"); + } + else + DIE(aTHX_ "Not a HASH reference"); + if (!sv) + sv = &PL_sv_undef; + if (gimme != G_VOID) + PUSHs(sv); + } + + RETURN; +} + +PP(pp_delete) +{ + dVAR; + dSP; + I32 gimme; + I32 discard; + + if (PL_op->op_private & OPpLVAL_INTRO) + return do_delete_local(); + + gimme = GIMME_V; + discard = (gimme == G_VOID) ? G_DISCARD : 0; if (PL_op->op_private & OPpSLICE) { dMARK; dORIGMARK; @@ -4201,17 +4384,11 @@ PP(pp_hslice) if (localizing) { if (HvNAME_get(hv) && isGV(*svp)) save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); - else { - if (preeminent) - save_helem_flags(hv, keysv, svp, - (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); - else { - STRLEN keylen; - const char * const key = SvPV_const(keysv, keylen); - SAVEDELETE(hv, savepvn(key,keylen), - SvUTF8(keysv) ? -(I32)keylen : (I32)keylen); - } - } + else if (preeminent) + save_helem_flags(hv, keysv, svp, + (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); + else + SAVEHDELETE(hv, keysv); } } *MARK = svp ? *svp : &PL_sv_undef; diff --git a/pp_hot.c b/pp_hot.c index 7afa422..8416eee 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1823,16 +1823,11 @@ PP(pp_helem) if (localizing) { if (HvNAME_get(hv) && isGV(*svp)) save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); - else { - if (!preeminent) { - STRLEN keylen; - const char * const key = SvPV_const(keysv, keylen); - SAVEDELETE(hv, savepvn(key,keylen), - SvUTF8(keysv) ? -(I32)keylen : (I32)keylen); - } else - save_helem_flags(hv, keysv, svp, - (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); - } + else if (preeminent) + save_helem_flags(hv, keysv, svp, + (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); + else + SAVEHDELETE(hv, keysv); } else if (PL_op->op_private & OPpDEREF) vivify_ref(*svp, PL_op->op_private & OPpDEREF); diff --git a/proto.h b/proto.h index 5a08e3e..53c738e 100644 --- a/proto.h +++ b/proto.h @@ -2746,10 +2746,14 @@ PERL_CALLCONV char* Perl_savesvpv(pTHX_ SV* sv) PERL_CALLCONV void Perl_savestack_grow(pTHX); PERL_CALLCONV void Perl_savestack_grow_cnt(pTHX_ I32 need); -PERL_CALLCONV void Perl_save_aelem(pTHX_ AV* av, I32 idx, SV **sptr) +/* PERL_CALLCONV void Perl_save_aelem(pTHX_ AV* av, I32 idx, SV **sptr) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_3); */ + +PERL_CALLCONV void Perl_save_aelem_flags(pTHX_ AV* av, I32 idx, SV **sptr, const U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); -#define PERL_ARGS_ASSERT_SAVE_AELEM \ +#define PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS \ assert(av); assert(sptr) PERL_CALLCONV I32 Perl_save_alloc(pTHX_ I32 size, I32 pad); @@ -2779,6 +2783,12 @@ PERL_CALLCONV void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) #define PERL_ARGS_ASSERT_SAVE_DELETE \ assert(hv); assert(key) +PERL_CALLCONV void Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_SAVE_HDELETE \ + assert(hv); assert(keysv) + PERL_CALLCONV void Perl_save_adelete(pTHX_ AV *av, I32 key) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SAVE_ADELETE \ @@ -4823,6 +4833,7 @@ STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) +STATIC OP* S_do_delete_local(pTHX); STATIC SV* S_refto(pTHX_ SV* sv) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); diff --git a/scope.c b/scope.c index 20e027f..50798e4 100644 --- a/scope.c +++ b/scope.c @@ -167,11 +167,14 @@ STATIC SV * S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) { dVAR; - SV * const osv = *sptr; - register SV * const sv = *sptr = newSV(0); + SV * osv; + register SV *sv; PERL_ARGS_ASSERT_SAVE_SCALAR_AT; + osv = *sptr; + sv = (flags & SAVEf_KEEPOLDELEM) ? osv : (*sptr = newSV(0)); + if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { if (SvGMAGICAL(osv)) { const bool oldtainted = PL_tainted; @@ -179,8 +182,10 @@ S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; PL_tainted = oldtainted; } - mg_localize(osv, sv, (flags & SAVEf_SETMAGIC) != 0); + if (!(flags & SAVEf_KEEPOLDELEM)) + mg_localize(osv, sv, (flags & SAVEf_SETMAGIC) != 0); } + return sv; } @@ -509,6 +514,21 @@ Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) } void +Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) +{ + STRLEN len; + I32 klen; + const char *key; + + PERL_ARGS_ASSERT_SAVE_HDELETE; + + key = SvPV_const(keysv, len); + klen = SvUTF8(keysv) ? -(I32)len : (I32)len; + SvREFCNT_inc_simple_void_NN(hv); + save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE); +} + +void Perl_save_adelete(pTHX_ AV *av, I32 key) { dVAR; @@ -572,12 +592,12 @@ S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, } void -Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr) +Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags) { dVAR; SV *sv; - PERL_ARGS_ASSERT_SAVE_AELEM; + PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS; SvGETMAGIC(*sptr); save_pushptri32ptr(SvREFCNT_inc_simple(av), idx, SvREFCNT_inc(*sptr), @@ -585,7 +605,9 @@ Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr) /* if it gets reified later, the restore will have the wrong refcnt */ if (!AvREAL(av) && AvREIFY(av)) SvREFCNT_inc_void(*sptr); - save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ + save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */ + if (flags & SAVEf_KEEPOLDELEM) + return; sv = *sptr; /* If we're localizing a tied array element, this new sv * won't actually be stored in the array - so it won't get @@ -610,6 +632,8 @@ Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) SSPUSHPTR(SvREFCNT_inc(*sptr)); SSPUSHINT(SAVEt_HELEM); save_scalar_at(sptr, flags); + if (flags & SAVEf_KEEPOLDELEM) + return; sv = *sptr; /* If we're localizing a tied hash element, this new sv * won't actually be stored in the hash - so it won't get diff --git a/scope.h b/scope.h index 2b57fc6..7517798 100644 --- a/scope.h +++ b/scope.h @@ -57,7 +57,9 @@ #define SAVEt_ADELETE 46 #define SAVEf_SETMAGIC 1 +#define SAVEf_KEEPOLDELEM 2 +#define save_aelem(av,idx,sptr) save_aelem_flags(av,idx,sptr,SAVEf_SETMAGIC) #define save_helem(hv,key,sptr) save_helem_flags(hv,key,sptr,SAVEf_SETMAGIC) #ifndef SCOPE_SAVES_SIGNAL_MASK @@ -143,6 +145,8 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. #define SAVESETSVFLAGS(sv,mask,val) save_set_svflags(sv,mask,val) #define SAVEDELETE(h,k,l) \ save_delete(MUTABLE_HV(h), (char*)(k), (I32)(l)) +#define SAVEHDELETE(h,s) \ + save_hdelete(MUTABLE_HV(h), (s)) #define SAVEADELETE(a,k) \ save_adelete(MUTABLE_AV(a), (I32)(k)) #define SAVEDESTRUCTOR(f,p) \ diff --git a/t/op/local.t b/t/op/local.t index 24acbff..211213b 100644 --- a/t/op/local.t +++ b/t/op/local.t @@ -5,7 +5,7 @@ BEGIN { @INC = qw(. ../lib); require './test.pl'; } -plan tests => 183; +plan tests => 296; my $list_assignment_supported = 1; @@ -158,6 +158,109 @@ is($a[0].$a[1], "Xb"); is("@a", $d); } +...@a = ('a', 'b', 'c'); +$a[4] = 'd'; +{ + delete local $a[1]; + is(scalar(@a), 5); + is($a[0], 'a'); + ok(!exists($a[1])); + is($a[2], 'c'); + ok(!exists($a[3])); + is($a[4], 'd'); + + ok(!exists($a[888])); + delete local $a[888]; + is(scalar(@a), 5); + ok(!exists($a[888])); + + ok(!exists($a[999])); + my ($d, $zzz) = delete local @a[4, 999]; + is(scalar(@a), 3); + ok(!exists($a[4])); + ok(!exists($a[999])); + is($d, 'd'); + is($zzz, undef); + + my $c = delete local $a[2]; + is(scalar(@a), 1); + ok(!exists($a[2])); + is($c, 'c'); + + $a[888] = 'yyy'; + $a[999] = 'zzz'; +} +is(scalar(@a), 5); +is($a[0], 'a'); +is($a[1], 'b'); +is($a[2], 'c'); +ok(!defined($a[3])); +is($a[4], 'd'); +ok(!exists($a[5])); +ok(!exists($a[888])); +ok(!exists($a[999])); + +%h = (a => 1, b => 2, c => 3, d => 4); +{ + delete local $h{b}; + is(scalar(keys(%h)), 3); + is($h{a}, 1); + ok(!exists($h{b})); + is($h{c}, 3); + is($h{d}, 4); + + ok(!exists($h{yyy})); + delete local $h{yyy}; + is(scalar(keys(%h)), 3); + ok(!exists($h{yyy})); + + ok(!exists($h{zzz})); + my ($d, $zzz) = delete local @h{qw/d zzz/}; + is(scalar(keys(%h)), 2); + ok(!exists($h{d})); + ok(!exists($h{zzz})); + is($d, 4); + is($zzz, undef); + + my $c = delete local $h{c}; + is(scalar(keys(%h)), 1); + ok(!exists($h{c})); + is($c, 3); + + $h{yyy} = 888; + $h{zzz} = 999; +} +is(scalar(keys(%h)), 4); +is($h{a}, 1); +is($h{b}, 2); +is($h{c}, 3); +ok($h{d}, 4); +ok(!exists($h{yyy})); +ok(!exists($h{zzz})); + +%h = ('a' => { 'b' => 1 }, 'c' => 2); +{ + my $a = delete local $h{a}; + is(scalar(keys(%h)), 1); + ok(!exists($h{a})); + is($h{c}, 2); + is(scalar(keys(%$a)), 1); + + my $b = delete local $a->{b}; + is(scalar(keys(%$a)), 0); + is($b, 1); + + $a->{d} = 3; +} +is(scalar(keys(%h)), 2); +{ + my $a = $h{a}; + is(scalar(keys(%$a)), 2); + is($a->{b}, 1); + is($a->{d}, 3); +} +is($h{c}, 2); + %h = ('a' => 1, 'b' => 2, 'c' => 3); { local($h{'a'}) = 'foo'; @@ -276,6 +379,48 @@ ok(!defined $a[4]); is($a[5], 'y'); ok(!exists $a[6]); +...@a = ('a', 'b', 'c'); +$a[4] = 'd'; +{ + delete local $a[1]; + is(scalar(@a), 5); + is($a[0], 'a'); + ok(!exists($a[1])); + is($a[2], 'c'); + ok(!exists($a[3])); + is($a[4], 'd'); + + ok(!exists($a[888])); + delete local $a[888]; + is(scalar(@a), 5); + ok(!exists($a[888])); + + ok(!exists($a[999])); + my ($d, $zzz) = delete local @a[4, 999]; + is(scalar(@a), 3); + ok(!exists($a[4])); + ok(!exists($a[999])); + is($d, 'd'); + is($zzz, undef); + + my $c = delete local $a[2]; + is(scalar(@a), 1); + ok(!exists($a[2])); + is($c, 'c'); + + $a[888] = 'yyy'; + $a[999] = 'zzz'; +} +is(scalar(@a), 5); +is($a[0], 'a'); +is($a[1], 'b'); +is($a[2], 'c'); +ok(!defined($a[3])); +is($a[4], 'd'); +ok(!exists($a[5])); +ok(!exists($a[888])); +ok(!exists($a[999])); + # see if localization works on tied hashes { package TH; @@ -315,6 +460,44 @@ TODO: { is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); } +%h = (a => 1, b => 2, c => 3, d => 4); +{ + delete local $h{b}; + is(scalar(keys(%h)), 3); + is($h{a}, 1); + ok(!exists($h{b})); + is($h{c}, 3); + is($h{d}, 4); + + ok(!exists($h{yyy})); + delete local $h{yyy}; + is(scalar(keys(%h)), 3); + ok(!exists($h{yyy})); + + ok(!exists($h{zzz})); + my ($d, $zzz) = delete local @h{qw/d zzz/}; + is(scalar(keys(%h)), 2); + ok(!exists($h{d})); + ok(!exists($h{zzz})); + is($d, 4); + is($zzz, undef); + + my $c = delete local $h{c}; + is(scalar(keys(%h)), 1); + ok(!exists($h{c})); + is($c, 3); + + $h{yyy} = 888; + $h{zzz} = 999; +} +is(scalar(keys(%h)), 4); +is($h{a}, 1); +is($h{b}, 2); +is($h{c}, 3); +ok($h{d}, 4); +ok(!exists($h{yyy})); +ok(!exists($h{zzz})); + @a = ('a', 'b', 'c'); { local($a[1]) = "X"; -- Perl5 Master Repository
