From: Vincent Pit Date: Mon, 29 Dec 2008 21:20:16 +0000 (+0100) Subject: Add localize_delete() X-Git-Tag: v0.03~10 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=44bf1ddcf3a97b602ae2c3ff267375989e5a4dfd Add localize_delete() --- diff --git a/MANIFEST b/MANIFEST index 55e9840..a6934e6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -21,6 +21,7 @@ t/31-localize_elem-level.t t/32-localize_elem-block.t t/38-localize_elem-magic.t t/39-localize_elem-target.t +t/40-localize_delete.t t/90-boilerplate.t t/91-pod.t t/92-pod-coverage.t diff --git a/Upper.xs b/Upper.xs index bf520ce..dd43b20 100644 --- a/Upper.xs +++ b/Upper.xs @@ -252,10 +252,14 @@ STATIC void su_localize(pTHX_ void *ud_) { if (SvTYPE(sv) >= SVt_PVGV) { gv = (GV *) sv; - if (!SvROK(val)) + if (!val) { /* local *x; */ + t = SVt_PVGV; + } else if (!SvROK(val)) { /* local *x = $val; */ goto assign; - t = SvTYPE(SvRV(val)); - deref = 1; + } else { /* local *x = \$val; */ + t = SvTYPE(SvRV(val)); + deref = 1; + } } else { STRLEN len, l; const char *p = SvPV_const(sv, len), *s; @@ -271,16 +275,16 @@ STATIC void su_localize(pTHX_ void *ud_) { case '&': t = SVt_PVCV; break; case '*': t = SVt_PVGV; break; } - if (t == SVt_NULL) { + if (t != SVt_NULL) { + ++s; + --l; + } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */ if (SvROK(val) && !sv_isobject(val)) { t = SvTYPE(SvRV(val)); deref = 1; } else { t = SvTYPE(val); } - } else { - ++s; - --l; } gv = gv_fetchpvn_flags(s, l, GV_ADDMULTI, SVt_PVGV); } @@ -304,7 +308,12 @@ STATIC void su_localize(pTHX_ void *ud_) { if (!*svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx); su_save_aelem(av, idx, svp, preeminent); gv = (GV *) *svp; - goto maybe_deref; + if (val) { /* local $x[$idx] = $val; */ + goto maybe_deref; + } else { /* local $x[$idx]; delete $x[$idx]; */ + av_delete(av, idx, G_DISCARD); + goto done; + } } else save_ary(gv); break; @@ -317,7 +326,12 @@ STATIC void su_localize(pTHX_ void *ud_) { if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp)); su_save_helem(hv, elem, svp, preeminent); gv = (GV *) *svp; - goto maybe_deref; + if (val) { /* local $x{$key} = $val; */ + goto maybe_deref; + } else { /* local $x{$key}; delete $x{$key}; */ + hv_delete_ent(hv, elem, G_DISCARD, HeHASH(he)); + goto done; + } } else save_hash(gv); break; @@ -331,7 +345,7 @@ STATIC void su_localize(pTHX_ void *ud_) { default: gv = (GV *) save_scalar(gv); maybe_deref: - if (deref) + if (deref) /* val != NULL */ val = SvRV(val); break; } @@ -341,8 +355,10 @@ maybe_deref: PL_scopestack[PL_scopestack_ix])); assign: - SvSetMagicSV((SV *) gv, val); + if (val) + SvSetMagicSV((SV *) gv, val); +done: SvREFCNT_dec(ud->elem); SvREFCNT_dec(ud->val); SvREFCNT_dec(ud->sv); @@ -539,3 +555,21 @@ CODE: SvREFCNT_inc(elem); ud->elem = elem; su_init(level, ud, 4); + +void +localize_delete(SV *sv, SV *elem, ...) +PROTOTYPE: $$;$ +PREINIT: + I32 level = 0; + su_ud_localize *ud; +CODE: + SU_GET_LEVEL(2); + Newx(ud, 1, su_ud_localize); + SU_UD_ORIGIN(ud) = NULL; + SU_UD_HANDLER(ud) = su_localize; + SvREFCNT_inc(sv); + ud->sv = sv; + ud->val = NULL; + SvREFCNT_inc(elem); + ud->elem = elem; + su_init(level, ud, 4); diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index f4e276d..5fa9a51 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -111,13 +111,20 @@ Similar to L but for array and hash elements. If C<$what> is a glob, the slot to fill is determined from which type of reference C<$value> is ; otherwise it's inferred from the sigil. C<$key> is either an array index or a hash key, depending of which kind of variable you localize. +=head2 C + +Similiar to L, but for deleting objects or elements. +If C<$what> is a glob, it's equivalent to C, and C<$key> is ignored. +If C<$what> is a string beginning with C<'@'> or C<'%'>, it's equivalent to respectiveley C or C. +If C<$what> is a string beginning with C<'&'>, it's more or less of equivalent to C, but actually more powerful as C<&func> won't even C anymore. + =head2 C Returns the level that currently represents the highest scope. =head1 EXPORT -The functions L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. +The functions L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. =cut @@ -125,7 +132,7 @@ use base qw/Exporter/; our @EXPORT = (); our %EXPORT_TAGS = ( - funcs => [ qw/reap localize localize_elem TOPLEVEL/ ], + funcs => [ qw/reap localize localize_elem localize_delete TOPLEVEL/ ], ); our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; diff --git a/t/40-localize_delete.t b/t/40-localize_delete.t new file mode 100644 index 0000000..6ddf79c --- /dev/null +++ b/t/40-localize_delete.t @@ -0,0 +1,139 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 30; + +use Scope::Upper qw/localize_delete/; + +# Arrays + +our @a; + +{ + local @a = (4 .. 6); + { + localize_delete '@main::a', 1, 0; + is_deeply \@a, [ 4, undef, 6 ], 'localize_delete "@a", 1, 0 [ok]'; + } + is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 1, 0 [end]'; +} + +{ + local @a = (4 .. 6); + { + localize_delete '@main::a', 4, 0; + is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (nonexistent), 0 [ok]'; + } + is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (nonexistent), 0 [end]'; +} + +{ + local @a = (4 .. 6); + local $a[4] = 7; + { + localize_delete '@main::a', 4, 0; + is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (exists), 0 [ok]'; + } + is_deeply \@a, [ 4 .. 6, undef, 7 ], 'localize_delete "@a", 4 (exists), 0 [end]'; +} + +{ + local @a = (4 .. 6); + { + local @a = (5 .. 7); + { + localize_delete '@main::a', 1, 1; + is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 1, 1 [not yet]'; + } + is_deeply \@a, [ 5, undef, 7 ], 'localize_delete "@a", 1, 1 [ok]'; + } + is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 1, 1 [end]'; +} + +{ + local @a = (4 .. 6); + { + local @a = (5 .. 7); + { + localize_delete '@main::a', 4, 1; + is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 4 (nonexistent), 1 [not yet]'; + } + is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 4 (nonexistent), 1 [ok]'; + } + is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (nonexistent), 1 [end]'; +} + +{ + local @a = (4 .. 6); + { + local @a = (5 .. 7); + local $a[4] = 8; + { + localize_delete '@main::a', 4, 1; + is_deeply \@a, [ 5 .. 7, undef, 8 ], 'localize_delete "@a", 4 (exists), 1 [not yet]'; + } + is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 4 (exists), 1 [ok]'; + } + is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (exists), 1 [end]'; +} + +# Hashes + +our %h; + +{ + local %h = (a => 1, b => 2); + { + localize_delete '%main::h', 'a', 0; + is_deeply \%h, { b => 2 }, 'localize_delete "%h", "a", 0 [ok]'; + } + is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "a", 0 [end]'; +} + +{ + local %h = (a => 1, b => 2); + { + localize_delete '%main::h', 'c', 0; + is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "c", 0 [ok]'; + } + is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "c", 0 [end]'; +} + +{ + local %h = (a => 1, b => 2); + { + local %h = (a => 3, c => 4); + { + localize_delete '%main::h', 'a', 1; + is_deeply \%h, { a => 3, c => 4 }, 'localize_delete "%h", "a", 1 [not yet]'; + } + is_deeply \%h, { c => 4 }, 'localize_delete "%h", "a", 1 [ok]'; + } + is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "a", 1 [end]'; +} + +# Others + +our $x = 1; +{ + localize_delete '$x', 2, 0; + is $x, undef, 'localize "$x", anything, 0 [ok]'; +} +is $x, 1, 'localize "$x", anything, 0 [end]'; + +sub x { 1 }; +{ + localize_delete '&x', 2, 0; + ok !exists(&x), 'localize "&x", anything, 0 [ok]'; +} +is x(), 1, 'localize "&x", anything, 0 [end]'; + +{ + localize_delete *x, sub { }, 0; + is !exists(&x), 1, 'localize *x, anything, 0 [ok 1]'; + is !defined($x), 1, 'localize *x, anything, 0 [ok 2]'; +} +is x(), 1, 'localize *x, anything, 0 [end 1]'; +is $x, 1, 'localize *x, anything, 0 [end 2]';