r59844 - in /trunk/libvariable-magic-perl: Changes META.yml Magic.xs README debian/changelog debian/rules lib/Variable/Magic.pm t/01-import.t t/14-callbacks.t t/17-ctl.t t/30-scalar.t t/34-glob.t
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Sun Jun 27 07:21:14 UTC 2010
Author: ansgar-guest
Date: Sun Jun 27 07:21:03 2010
New Revision: 59844
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=59844
Log:
* New upstream release (0.43).
* debian/rules: Use 'find -exec ... {} +' instead of find and xargs.
Modified:
trunk/libvariable-magic-perl/Changes
trunk/libvariable-magic-perl/META.yml
trunk/libvariable-magic-perl/Magic.xs
trunk/libvariable-magic-perl/README
trunk/libvariable-magic-perl/debian/changelog
trunk/libvariable-magic-perl/debian/rules
trunk/libvariable-magic-perl/lib/Variable/Magic.pm
trunk/libvariable-magic-perl/t/01-import.t
trunk/libvariable-magic-perl/t/14-callbacks.t
trunk/libvariable-magic-perl/t/17-ctl.t
trunk/libvariable-magic-perl/t/30-scalar.t
trunk/libvariable-magic-perl/t/34-glob.t
Modified: trunk/libvariable-magic-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/Changes?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/Changes (original)
+++ trunk/libvariable-magic-perl/Changes Sun Jun 27 07:21:03 2010
@@ -1,4 +1,13 @@
Revision history for Variable-Magic
+
+0.43 2010-06-25 23:35 UTC
+ + Add : The new constant VMG_COMPAT_GLOB_GET tells you whether get magic
+ is called for globs. It's true starting perl 5.13.2.
+ + Chg : All callbacks are now called within an eval-like context.
+ Only free callbacks used to be called that way.
+ + Fix : Some exceptions thrown from a free callback could be lost.
+ + Fix : Croak messages could sometimes be repeated several times.
+ + Fix : t/41-clone.t segfaulting with perl 5.13.2.
0.42 2010-05-19 00:15 UTC
This is a maintenance release. The code contains no functional change.
Modified: trunk/libvariable-magic-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/META.yml?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/META.yml (original)
+++ trunk/libvariable-magic-perl/META.yml Sun Jun 27 07:21:03 2010
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Variable-Magic
-version: 0.42
+version: 0.43
abstract: Associate user-defined magic to variables from Perl.
author:
- Vincent Pit <perl at profvince.com>
Modified: trunk/libvariable-magic-perl/Magic.xs
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/Magic.xs?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/Magic.xs (original)
+++ trunk/libvariable-magic-perl/Magic.xs Sun Jun 27 07:21:03 2010
@@ -79,13 +79,25 @@
STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
#define vmg_clone(P, O) vmg_clone(aTHX_ (P), (O))
+ SV *dupsv;
+
+#if VMG_HAS_PERL(5, 13, 2)
+ CLONE_PARAMS *param = Perl_clone_params_new(owner, aTHX);
+
+ dupsv = sv_dup(sv, param);
+
+ Perl_clone_params_del(param);
+#else
CLONE_PARAMS param;
param.stashes = NULL; /* don't need it unless sv is a PVHV */
param.flags = 0;
param.proto_perl = owner;
- return SvREFCNT_inc(sv_dup(sv, ¶m));
+ dupsv = sv_dup(sv, ¶m);
+#endif
+
+ return SvREFCNT_inc(dupsv);
}
#endif /* VMG_THREADSAFE */
@@ -134,16 +146,6 @@
#ifndef IN_PERL_COMPILETIME
# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
-#endif
-
-#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
-# ifndef PL_error_count
-# define PL_error_count PL_parser->error_count
-# endif
-#else
-# ifndef PL_error_count
-# define PL_error_count PL_Ierror_count
-# endif
#endif
/* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only
@@ -194,9 +196,18 @@
# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
#endif
+#if VMG_HAS_PERL(5, 13, 2)
+# define VMG_COMPAT_GLOB_GET 1
+#else
+# define VMG_COMPAT_GLOB_GET 0
+#endif
+
+/* ... Bug-free mg_magical ................................................. */
+
+/* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html. This version is specialized to our needs. */
+
#if VMG_UVAR
-/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html - but specialized to our needs. */
STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
#define vmg_sv_magicuvar(S, U, L) vmg_sv_magicuvar(aTHX_ (S), (U), (L))
const MAGIC* mg;
@@ -217,6 +228,75 @@
}
#endif /* VMG_UVAR */
+
+/* ... Safe version of call_sv() ........................................... */
+
+#define VMG_SAVE_LAST_CX (!VMG_HAS_PERL(5, 8, 4) || VMG_HAS_PERL(5, 9, 5))
+
+STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, I32 destructor) {
+#define vmg_call_sv(S, F, D) vmg_call_sv(aTHX_ (S), (F), (D))
+ I32 ret, cxix = 0, in_eval = 0;
+#if VMG_SAVE_LAST_CX
+ PERL_CONTEXT saved_cx;
+#endif
+ SV *old_err = NULL;
+
+ if (SvTRUE(ERRSV)) {
+ old_err = ERRSV;
+ ERRSV = newSV(0);
+ }
+
+ if (cxstack_ix < cxstack_max) {
+ cxix = cxstack_ix + 1;
+ if (destructor && CxTYPE(cxstack + cxix) == CXt_EVAL)
+ in_eval = 1;
+ }
+
+#if VMG_SAVE_LAST_CX
+ /* The last popped context will be reused by call_sv(), but our callers may
+ * still need its previous value. Back it up so that it isn't clobbered. */
+ saved_cx = cxstack[cxix];
+#endif
+
+ ret = call_sv(sv, flags | G_EVAL);
+
+#if VMG_SAVE_LAST_CX
+ cxstack[cxix] = saved_cx;
+#endif
+
+ if (SvTRUE(ERRSV)) {
+ if (old_err) {
+ sv_setsv(old_err, ERRSV);
+ SvREFCNT_dec(ERRSV);
+ ERRSV = old_err;
+ }
+ if (IN_PERL_COMPILETIME) {
+ if (!PL_in_eval) {
+ if (PL_errors)
+ sv_catsv(PL_errors, ERRSV);
+ else
+ Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV));
+ SvCUR_set(ERRSV, 0);
+ }
+#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
+ if (PL_parser)
+ ++PL_parser->error_count;
+#elif defined(PL_error_count)
+ ++PL_error_count;
+#else
+ ++PL_Ierror_count;
+#endif
+ } else if (!in_eval)
+ croak(NULL);
+ } else {
+ if (old_err) {
+ SvREFCNT_dec(ERRSV);
+ ERRSV = old_err;
+ }
+ }
+
+ return ret;
+}
/* --- Stolen chunk of B --------------------------------------------------- */
@@ -632,7 +712,7 @@
PUSHs(args[i]);
PUTBACK;
- call_sv(ctor, G_SCALAR);
+ vmg_call_sv(ctor, G_SCALAR, 0);
SPAGAIN;
nsv = POPs;
@@ -943,7 +1023,7 @@
XPUSHs(vmg_op_info(opinfo));
PUTBACK;
- call_sv(cb, G_SCALAR);
+ vmg_call_sv(cb, G_SCALAR, 0);
SPAGAIN;
svr = POPs;
@@ -1016,7 +1096,7 @@
XPUSHs(vmg_op_info(opinfo));
PUTBACK;
- call_sv(w->cb_len, G_SCALAR);
+ vmg_call_sv(w->cb_len, G_SCALAR, 0);
SPAGAIN;
svr = POPs;
@@ -1038,11 +1118,6 @@
STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
const MGWIZ *w;
-#if VMG_HAS_PERL(5, 9, 5)
- PERL_CONTEXT saved_cx;
- I32 cxix;
-#endif
- I32 had_err, has_err, flags = G_SCALAR | G_EVAL;
int ret = 0;
SV *svr;
@@ -1076,38 +1151,7 @@
XPUSHs(vmg_op_info(w->opinfo));
PUTBACK;
- had_err = SvTRUE(ERRSV);
- if (had_err)
- flags |= G_KEEPERR;
-
-#if VMG_HAS_PERL(5, 9, 5)
- /* This context should not be used anymore, but since we croak in places the
- * core doesn't even dare to, some pointers to it may remain in the upper call
- * stack. Make sure call_sv() doesn't clobber it. */
- if (cxstack_ix < cxstack_max)
- cxix = cxstack_ix + 1;
- else
- cxix = Perl_cxinc(aTHX);
- saved_cx = cxstack[cxix];
-#endif
-
- call_sv(w->cb_free, flags);
-
-#if VMG_HAS_PERL(5, 9, 5)
- cxstack[cxix] = saved_cx;
-#endif
-
- has_err = SvTRUE(ERRSV);
- if (IN_PERL_COMPILETIME && !had_err && has_err) {
- if (PL_errors)
- sv_catsv(PL_errors, ERRSV);
- else
- Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV));
-#ifdef PL_parser
- if (PL_parser)
-#endif
- ++PL_error_count;
- }
+ vmg_call_sv(w->cb_free, G_SCALAR, 1);
SPAGAIN;
svr = POPs;
@@ -1319,6 +1363,7 @@
newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
+ newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET));
newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE));
newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(VMG_FORKSAFE));
Modified: trunk/libvariable-magic-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/README?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/README (original)
+++ trunk/libvariable-magic-perl/README Sun Jun 27 07:21:03 2010
@@ -2,7 +2,7 @@
Variable::Magic - Associate user-defined magic to variables from Perl.
VERSION
- Version 0.42
+ Version 0.43
SYNOPSIS
use Variable::Magic qw/wizard cast VMG_OP_INFO_NAME/;
@@ -328,6 +328,9 @@
"VMG_COMPAT_SCALAR_LENGTH_NOLEN"
True for perls that don't call 'len' magic when taking the "length" of a
magical scalar.
+
+ "VMG_COMPAT_GLOB_GET"
+ True for perls that call 'get' magic for operations on globs.
"VMG_PERL_PATCHLEVEL"
The perl patchlevel this module was built with, or 0 for non-debugging
Modified: trunk/libvariable-magic-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/debian/changelog?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/debian/changelog (original)
+++ trunk/libvariable-magic-perl/debian/changelog Sun Jun 27 07:21:03 2010
@@ -1,12 +1,14 @@
-libvariable-magic-perl (0.42-1) UNRELEASED; urgency=low
+libvariable-magic-perl (0.43-1) unstable; urgency=low
- IGNORE-VERSION: 0.42-1
- Only changes in tests
-
- * New upstream release
+ [ Angel Abad ]
+ * New upstream release (0.42)
* Convert to source format 3.0 (quilt)
- -- Angel Abad <angelabad at gmail.com> Wed, 19 May 2010 11:39:58 +0200
+ [ Ansgar Burchardt ]
+ * New upstream release (0.43).
+ * debian/rules: Use 'find -exec ... {} +' instead of find and xargs.
+
+ -- Ansgar Burchardt <ansgar at 43-1.org> Sun, 27 Jun 2010 16:11:50 +0900
libvariable-magic-perl (0.41-1) unstable; urgency=low
Modified: trunk/libvariable-magic-perl/debian/rules
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/debian/rules?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/debian/rules (original)
+++ trunk/libvariable-magic-perl/debian/rules Sun Jun 27 07:21:03 2010
@@ -7,7 +7,6 @@
override_dh_installexamples:
dh_installexamples
- find $(CURDIR)/debian/$(PKG)/usr/share/doc/$(PKG)/examples -type f -print0 | \
- xargs -r0 \
- sed -i -e 's;^#.*perl;#!/usr/bin/perl;'
+ find $(CURDIR)/debian/$(PKG)/usr/share/doc/$(PKG)/examples -type f \
+ -exec sed -i -e 's;^#.*perl;#!/usr/bin/perl;' {} +
Modified: trunk/libvariable-magic-perl/lib/Variable/Magic.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/lib/Variable/Magic.pm?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/lib/Variable/Magic.pm (original)
+++ trunk/libvariable-magic-perl/lib/Variable/Magic.pm Sun Jun 27 07:21:03 2010
@@ -13,13 +13,13 @@
=head1 VERSION
-Version 0.42
+Version 0.43
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.42';
+ $VERSION = '0.43';
}
=head1 SYNOPSIS
@@ -391,6 +391,10 @@
=head2 C<VMG_COMPAT_SCALAR_LENGTH_NOLEN>
True for perls that don't call 'len' magic when taking the C<length> of a magical scalar.
+
+=head2 C<VMG_COMPAT_GLOB_GET>
+
+True for perls that call 'get' magic for operations on globs.
=head2 C<VMG_PERL_PATCHLEVEL>
@@ -563,16 +567,17 @@
our @EXPORT = ();
our %EXPORT_TAGS = (
'funcs' => [ qw/wizard cast getdata dispell/ ],
- 'consts' => [
- qw/MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/,
- qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID/,
- qw/VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID/,
- qw/VMG_COMPAT_ARRAY_UNDEF_CLEAR/,
- qw/VMG_COMPAT_SCALAR_LENGTH_NOLEN/,
- qw/VMG_PERL_PATCHLEVEL/,
- qw/VMG_THREADSAFE VMG_FORKSAFE/,
- qw/VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/
- ]
+ 'consts' => [ qw/
+ MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR
+ VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
+ VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
+ VMG_COMPAT_ARRAY_UNDEF_CLEAR
+ VMG_COMPAT_SCALAR_LENGTH_NOLEN
+ VMG_COMPAT_GLOB_GET
+ VMG_PERL_PATCHLEVEL
+ VMG_THREADSAFE VMG_FORKSAFE
+ VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT
+ / ],
);
our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
Modified: trunk/libvariable-magic-perl/t/01-import.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/t/01-import.t?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/t/01-import.t (original)
+++ trunk/libvariable-magic-perl/t/01-import.t Sun Jun 27 07:21:03 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 2 * 18;
+use Test::More tests => 2 * 19;
require Variable::Magic;
@@ -18,6 +18,7 @@
VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
VMG_COMPAT_ARRAY_UNDEF_CLEAR
VMG_COMPAT_SCALAR_LENGTH_NOLEN
+ VMG_COMPAT_GLOB_GET
VMG_PERL_PATCHLEVEL
VMG_THREADSAFE VMG_FORKSAFE
VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT
Modified: trunk/libvariable-magic-perl/t/14-callbacks.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/t/14-callbacks.t?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/t/14-callbacks.t (original)
+++ trunk/libvariable-magic-perl/t/14-callbacks.t Sun Jun 27 07:21:03 2010
@@ -59,20 +59,20 @@
my $u = $b;
is_deeply(\@callers, [
- [ 'main', $0, __LINE__-2 ],
+ ([ 'main', $0, __LINE__-2 ]) x 2,
], 'caller into callback returns the right thing');
@callers = ();
$u = $b;
is_deeply(\@callers, [
- [ 'main', $0, __LINE__-2 ],
+ ([ 'main', $0, __LINE__-2 ]) x 2,
], 'caller into callback returns the right thing (second time)');
{
@callers = ();
my $u = $b;
is_deeply(\@callers, [
- [ 'main', $0, __LINE__-2 ],
+ ([ 'main', $0, __LINE__-2 ]) x 2,
], 'caller into callback into block returns the right thing');
}
@@ -80,6 +80,6 @@
eval { my $u = $b };
is($@, '', 'caller into callback doesn\'t croak');
is_deeply(\@callers, [
- ([ 'main', $0, __LINE__-3 ]) x 2,
+ ([ 'main', $0, __LINE__-3 ]) x 3,
], 'caller into callback into eval returns the right thing');
Modified: trunk/libvariable-magic-perl/t/17-ctl.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/t/17-ctl.t?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/t/17-ctl.t (original)
+++ trunk/libvariable-magic-perl/t/17-ctl.t Sun Jun 27 07:21:03 2010
@@ -1,41 +1,134 @@
-#!perl -T
+#!perl
use strict;
use warnings;
-use Test::More tests => 10 + 1;
-
-use Variable::Magic qw/wizard cast/;
+use Test::More tests => 4 * 8 + 10 + 1 + 1;
+
+use Variable::Magic qw/wizard cast VMG_UVAR/;
+
+sub expect {
+ my ($name, $where, $suffix) = @_;
+ $where = defined $where ? quotemeta $where : '\(eval \d+\)';
+ my $end = defined $suffix ? "$suffix\$" : '$';
+ qr/^\Q$name\E at $where line \d+\.$end/
+}
+
+my @scalar_tests = (
+ [ 'data', sub { \(my $x) }, sub { } ],
+ [ 'get', sub { \(my $x) }, sub { my $y = ${$_[0]} } ],
+ [ 'set', sub { \(my $x) }, sub { ${$_[0]} = 1 } ],
+ [ 'len', sub { [ 1 .. 3 ] }, sub { my $res = @{$_[0]} } ],
+);
+
+# Data, get, set, len
+
+for my $t (@scalar_tests) {
+ my ($name, $init, $code) = @$t;
+
+ my $wiz = wizard $name => sub { die 'leek' };
+
+ {
+ local $@;
+ eval {
+ my $x = $init->();
+ &cast($x, $wiz);
+ $code->($x);
+ };
+ like $@, expect('leek', $0),
+ "die in $name callback (direct, \$@ unset) in eval";
+ }
+
+ {
+ local $@;
+ eval {
+ my $x = $init->();
+ &cast($x, $wiz);
+ $@ = 'artichoke';
+ $code->($x);
+ };
+ like $@, expect('leek', $0),
+ "die in $name callback (direct, \$@ set) in eval";
+ }
+
+ {
+ local $@;
+ eval q{BEGIN {
+ my $x = $init->();
+ &cast($x, $wiz);
+ $code->($x);
+ }};
+ like $@, expect('leek', $0, "\nBEGIN.*"),
+ "die in $name callback (direct, \$@ unset) in BEGIN";
+ }
+
+ {
+ local $@;
+ eval q{BEGIN {
+ my $x = $init->();
+ &cast($x, $wiz);
+ $@ = 'artichoke';
+ $code->($x);
+ }};
+ like $@, expect('leek', $0, "\nBEGIN.*"),
+ "die in $name callback (direct, \$@ set) in BEGIN";
+ }
+
+ $wiz = wizard(
+ ($name eq 'data' ? () : (data => sub { $_[1] })),
+ $name => sub { $_[1]->(); () },
+ );
+
+ {
+ local $@;
+ eval {
+ my $x = $init->();
+ &cast($x, $wiz, sub { die 'lettuce' });
+ $code->($x);
+ };
+ like $@, expect('lettuce', $0),
+ "die in $name callback (indirect, \$@ unset) in eval";
+ }
+
+ {
+ local $@;
+ eval {
+ my $x = $init->();
+ &cast($x, $wiz, sub { die 'carrot' });
+ $@ = 'artichoke';
+ $code->($x);
+ };
+ like $@, expect('carrot', $0),
+ "die in $name callback (indirect, \$@ unset) in eval";
+ }
+
+ {
+ local $@;
+ eval q{BEGIN {
+ my $x = $init->();
+ &cast($x, $wiz, sub { die "pumpkin" });
+ $code->($x);
+ }};
+ like $@, expect('pumpkin', undef, "\nBEGIN.*"),
+ "die in $name callback (indirect, \$@ unset) in BEGIN";
+ }
+
+ {
+ local $@;
+ eval q{BEGIN {
+ my $x = $init->();
+ &cast($x, $wiz, sub { die "chard" });
+ $@ = 'artichoke';
+ $code->($x);
+ }};
+ like $@, expect('chard', undef, "\nBEGIN.*"),
+ "die in $name callback (indirect, \$@ set) in BEGIN";
+ }
+}
+
+# Free
my $wiz;
-
-eval {
- $wiz = wizard data => sub { $_[1]->() };
- my $x;
- cast $x, $wiz, sub { die "carrot" };
-};
-
-like $@, qr/carrot/, 'die in data callback';
-
-eval {
- $wiz = wizard data => sub { $_[1] },
- set => sub { $_[1]->(); () };
- my $x;
- cast $x, $wiz, sub { die "lettuce" };
- $x = 5;
-};
-
-like $@, qr/lettuce/, 'die in set callback';
-
-my $res = eval {
- $wiz = wizard data => sub { $_[1] },
- len => sub { $_[1]->(); () };
- my @a = (1 .. 3);
- cast @a, $wiz, sub { die "potato" };
- @a;
-};
-
-like $@, qr/potato/, 'die in len callback';
eval {
$wiz = wizard data => sub { $_[1] },
@@ -44,26 +137,41 @@
cast $x, $wiz, sub { die "spinach" };
};
-like $@, qr/spinach/, 'die in free callback';
-
-# Inspired by B::Hooks::EndOfScope
-
-eval q{BEGIN {
- $wiz = wizard data => sub { $_[1]->() };
+like $@, expect('spinach', $0), 'die in free callback';
+
+eval {
+ $wiz = wizard free => sub { die 'zucchini' };
+ $@ = "";
+ {
+ my $x;
+ cast $x, $wiz;
+ }
+ die 'not reached';
+};
+
+like $@, expect('zucchini', $0),
+ 'die in free callback in block in eval with $@ unset';
+
+eval {
+ $wiz = wizard free => sub { die 'eggplant' };
+ $@ = "artichoke";
+ {
+ my $x;
+ cast $x, $wiz;
+ }
+ die 'not reached again';
+};
+
+like $@, expect('eggplant', $0),
+ 'die in free callback in block in eval with $@ set';
+
+eval q{BEGIN {
+ $wiz = wizard free => sub { die 'onion' };
my $x;
- cast $x, $wiz, sub { die "pumpkin" };
-}};
-
-like $@, qr/pumpkin/, 'die in data callback in BEGIN';
-
-eval q{BEGIN {
- $wiz = wizard data => sub { $_[1] },
- free => sub { $_[1]->(); () };
- $^H |= 0x020000;
- cast %^H, $wiz, sub { die "macaroni" };
-}};
-
-like $@, qr/macaroni/, 'die in free callback in BEGIN';
+ cast $x, $wiz;
+}};
+
+like $@, expect('onion', undef, "\nBEGIN.*"), 'die in free callback in BEGIN';
eval q{BEGIN {
$wiz = wizard data => sub { $_[1] },
@@ -73,12 +181,27 @@
cast @a, $wiz, sub { die "pepperoni" };
}};
-like $@, qr/pepperoni/, 'die in len callback in BEGIN';
+like $@, expect('pepperoni', undef, "\nBEGIN.*"),
+ 'die in free callback in len callback in BEGIN';
+
+# Inspired by B::Hooks::EndOfScope
+
+eval q{BEGIN {
+ $wiz = wizard data => sub { $_[1] },
+ free => sub { $_[1]->(); () };
+ $^H |= 0x020000;
+ cast %^H, $wiz, sub { die 'cabbage' };
+}};
+
+like $@, expect('cabbage'), 'die in free callback at end of scope';
use lib 't/lib';
+
+my $vm_tse_file = 't/lib/Variable/Magic/TestScopeEnd.pm';
+
eval "use Variable::Magic::TestScopeEnd";
-
-like $@, qr/turnip/, 'die in BEGIN in require triggers hints hash destructor';
+like $@, expect('turnip', $vm_tse_file, "\nBEGIN(?s:.*)"),
+ 'die in BEGIN in require in eval string triggers hints hash destructor';
eval q{BEGIN {
Variable::Magic::TestScopeEnd::hook {
@@ -87,4 +210,56 @@
die "tomato";
}};
-like $@, qr/tomato/, 'die in BEGIN in eval triggers hints hash destructor';
+like $@, expect('tomato', undef, "\nBEGIN.*"),
+ 'die in BEGIN in eval triggers hints hash destructor';
+
+sub run_perl {
+ my $code = shift;
+
+ my $SystemRoot = $ENV{SystemRoot};
+ local %ENV;
+ $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
+
+ system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
+}
+
+my $has_capture_tiny = do { local $@; eval 'use Capture::Tiny 0.08 (); 1' };
+
+SKIP:
+{
+ my $count = 1;
+
+ skip 'Capture::Tiny 0.08 is not installed' => $count unless $has_capture_tiny;
+
+ my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
+use Variable::Magic qw/wizard cast/; { BEGIN { $^H |= 0x020000; cast %^H, wizard free => sub { die q[cucumber] } } }
+ CODE
+ skip 'Test code didn\'t run properly' => 1 unless defined $output;
+ like $output, expect('cucumber', '-e', "\nExecution(?s:.*)"),
+ 'die in free callback at compile time and not in eval string';
+ --$count;
+}
+
+# Uvar
+
+SKIP:
+{
+ my $count = 1;
+
+ skip 'No nice uvar magic for this perl' => $count unless VMG_UVAR;
+ skip 'Capture::Tiny 0.08 is not installed' => $count unless $has_capture_tiny;
+
+ my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' });
+use Variable::Magic qw/wizard cast/; BEGIN { cast %::, wizard fetch => sub { die q[salsify] } } hlagh()
+ CODE
+ skip 'Test code didn\'t run properly' => $count unless defined $output;
+ my $suffix = "\nExecution(?s:.*)";
+ if ($] >= 5.011005) {
+ $suffix = "(?:\nsalsify at -e line \\d+.){12}" . $suffix;
+ } elsif ($] >= 5.011) {
+ $suffix = "(?:\nsalsify at -e line \\d+.){3}" . $suffix;
+ }
+ like $output, expect('salsify', '-e', $suffix),
+ 'die in free callback at compile time and not in eval string';
+ --$count;
+}
Modified: trunk/libvariable-magic-perl/t/30-scalar.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/t/30-scalar.t?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/t/30-scalar.t (original)
+++ trunk/libvariable-magic-perl/t/30-scalar.t Sun Jun 27 07:21:03 2010
@@ -106,8 +106,6 @@
unless (MGf_COPY) {
$SKIP = 'No copy magic for this perl';
- } elsif ($Config{useithreads} and $] le 5.008003) {
- $SKIP = 'Causes havoc during global destruction for old threaded perls';
} else {
eval "use Tie::Array";
$SKIP = 'Tie::Array required to test clear magic on tied array values' if $@;
Modified: trunk/libvariable-magic-perl/t/34-glob.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libvariable-magic-perl/t/34-glob.t?rev=59844&op=diff
==============================================================================
--- trunk/libvariable-magic-perl/t/34-glob.t (original)
+++ trunk/libvariable-magic-perl/t/34-glob.t Sun Jun 27 07:21:03 2010
@@ -13,7 +13,9 @@
diag "Using Symbol $Symbol::VERSION" if defined $Symbol::VERSION;
}
-use Variable::Magic qw/cast dispell/;
+use Variable::Magic qw/cast dispell VMG_COMPAT_GLOB_GET/;
+
+my %get = VMG_COMPAT_GLOB_GET ? (get => 1) : ();
use lib 't/lib';
use Variable::Magic::TestWatcher;
@@ -24,17 +26,17 @@
local *a = gensym();
-watch { cast *a, $wiz } { }, 'cast';
+watch { cast *a, $wiz } +{ }, 'cast';
-watch { local *b = *a } { }, 'assign to';
+watch { local *b = *a } +{ %get }, 'assign to';
-watch { *a = gensym() } { set => 1 }, 'assign';
+watch { *a = gensym() } +{ %get, set => 1 }, 'assign';
watch {
local *b = gensym();
- watch { cast *b, $wiz } { }, 'cast 2';
-} { }, 'scope end';
+ watch { cast *b, $wiz } +{ }, 'cast 2';
+} +{ }, 'scope end';
-watch { undef *a } { }, 'undef';
+watch { undef *a } +{ %get }, 'undef';
-watch { dispell *a, $wiz } { }, 'dispell';
+watch { dispell *a, $wiz } +{ %get }, 'dispell';
More information about the Pkg-perl-cvs-commits
mailing list