Revision history for Variable-Magic
+0.16 2008-05-10 22:05 UTC
+ + Add : The samples/copy.pl script.
+ + Chg : The sv_magical() + vmg_mg_magical() combo was simplified into
+ vmg_sv_magicuvar().
+ + Tst : t/33-code.t was testing scalars, not code.
+ + Tst : is() and like() are better than ok().
+ + Tst : 100% coverage reached.
+
0.15 2008-04-11 18:25 UTC
+ Chg : Factor vmg_cb_call{1,2,3}() into one function.
+ Fix : len magic is no longer called when taking the length() of a
Makefile.PL
README
lib/Variable/Magic.pm
+samples/copy.pl
samples/magic.pl
samples/uvar.pl
samples/vm_vs_tie.pl
--- #YAML:1.0
name: Variable-Magic
-version: 0.15
+version: 0.16
abstract: Associate user-defined magic to variables from Perl.
license: perl
author:
#if VMG_UVAR
-/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */
-STATIC void vmg_mg_magical(pTHX_ SV *sv) {
-#define vmg_mg_magical(S) vmg_mg_magical(aTHX_ (S))
+/* 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;
+ sv_magic(sv, NULL, PERL_MAGIC_uvar, uf, len);
+ /* uvar magic has set and get magic, hence this has set SVs_GMG and SVs_SMG. */
PERL_UNUSED_CONTEXT;
if ((mg = SvMAGIC(sv))) {
SvRMAGICAL_off(sv);
do {
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl) {
+/*
if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
SvGMAGICAL_on(sv);
if (vtbl->svt_set)
SvSMAGICAL_on(sv);
- if (vtbl->svt_clear)
+*/
+ if (vtbl->svt_clear) {
SvRMAGICAL_on(sv);
+ break;
+ }
}
} while ((mg = mg->mg_moremagic));
+/*
if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
SvRMAGICAL_on(sv);
+*/
}
}
}
if (add_uvar) {
- sv_magic(sv, NULL, PERL_MAGIC_uvar, (const char *) &uf, sizeof(uf));
- vmg_mg_magical(sv);
+ vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
}
}
PUSHs(data ? data : &PL_sv_undef);
va_start(ap, args);
for (i = 0; i < args; ++i) {
- SV *sv = va_arg(ap, SV *);
- PUSHs(sv ? sv : &PL_sv_undef);
+ SV *sva = va_arg(ap, SV *);
+ PUSHs(sva ? sva : &PL_sv_undef);
}
va_end(ap);
PUTBACK;
PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
if (SvTYPE(sv) == SVt_PVAV) {
len = av_len((AV *) sv) + 1;
- PUSHs(sv_2mortal(newSViv(len)));
+ mPUSHi(len);
} else {
+ len = 1;
PUSHs(&PL_sv_undef);
}
PUTBACK;
if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
svr = POPs;
- ret = SvOK(svr) ? SvUV(svr)
- : ((SvTYPE(sv) == SVt_PVAV) ? len : 1);
+ ret = SvOK(svr) ? SvUV(svr) : len;
PUTBACK;
Variable::Magic - Associate user-defined magic to variables from Perl.
VERSION
- Version 0.15
+ Version 0.16
SYNOPSIS
use Variable::Magic qw/wizard cast dispell/;
=head1 VERSION
-Version 0.15
+Version 0.16
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.15';
+ $VERSION = '0.16';
}
=head1 SYNOPSIS
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use lib qw{blib/arch blib/lib};
+use Variable::Magic qw/wizard getsig cast/;
+use Tie::Hash;
+
+my $wiz = wizard copy => sub { print STDERR "COPY $_[2] => $_[3]\n" },
+ free => sub { print STDERR "FREE\n" };
+my %h;
+tie %h, 'Tie::StdHash';
+%h = (a => 1, b => 2);
+cast %h, $wiz;
+$h{b} = 3;
+my $x = delete $h{b};
+$x == 3 or die 'incorrect';
my $x = 0;
+print "Using Variable::Magic ", $Variable::Magic::VERSION, "\n";
cmpthese -3, {
'tie' => sub { my ($x, $y) = map @a[$x++ % @a], 1 .. 2; my $a = $t{$x}; $t{$y} = $a },
'v::m' => sub { my ($x, $y) = map @a[$x++ % @a], 1 .. 2; my $a = $v{$x}; $v{$y} = $a }
for (qw/wizard gensig getsig cast getdata dispell SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN/) {
eval { Variable::Magic->import($_) };
- ok(!$@, 'import ' . $_);
+ is($@, '', 'import ' . $_);
}
for (0 .. 20) {
next if $_ == $args;
eval { Variable::Magic::_wizard(('hlagh') x $_) };
- ok($@, "_wizard called directly with a wrong number of arguments croaks ($@)");
+ like($@, qr/Wrong\s+number\s+of\s+arguments/, '_wizard called directly with a wrong number of arguments croaks');
}
for (0 .. 3) {
eval { wizard(('dong') x (2 * $_ + 1)) };
- ok($@, "wizard called with an odd number of arguments croaks ($@)");
+ like($@, qr/Wrong\s+number\s+of\s+arguments\s+for\s+wizard\(\)/, 'wizard called with an odd number of arguments croaks');
}
my $sig = gensig;
my $wiz = eval { wizard sig => $sig };
-ok(!$@, "wizard doesn't croak ($@)");
+is($@, '', 'wizard doesn\'t croak');
ok(defined $wiz, 'wizard is defined');
is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
is($sig, getsig $wiz, 'wizard signature is correct');
my $a = 1;
my $res = eval { cast $a, $wiz };
-ok(!$@, "cast doesn't croak ($@)");
-ok($res, 'cast is valid');
+is($@, '', 'cast doesn\'t croak');
+ok($res, 'cast is valid');
$res = eval { dispell $a, $wiz };
-ok(!$@, "dispell from wizard doesn't croak ($@)");
-ok($res, 'dispell from wizard is valid');
+is($@, '', 'dispell from wizard doesn\'t croak');
+ok($res, 'dispell from wizard is valid');
$res = eval { cast $a, $wiz };
-ok(!$@, "re-cast doesn't croak ($@)");
-ok($res, 're-cast is valid');
+is($@, '', 're-cast doesn\'t croak');
+ok($res, 're-cast is valid');
$res = eval { dispell $a, gensig };
-ok(!$@, "re-dispell from wrong sig doesn't croak ($@)");
-ok(!defined($res), 're-dispell from wrong sig returns undef');
+is($@, '', 're-dispell from wrong sig doesn\'t croak');
+is($res, undef, 're-dispell from wrong sig doesn\'t return anything');
$res = eval { dispell $a, undef };
-ok($@, "re-dispell from undef croaks ($@)");
-ok(!defined($res), 're-dispell from undef returns undef');
+like($@, qr/Invalid\s+wizard\s+object/, 're-dispell from undef croaks');
+is($res, undef, 're-dispell from undef doesn\'t return anything');
$res = eval { dispell $a, $sig };
-ok(!$@, "re-dispell from good sig doesn't croak ($@)");
-ok($res, 're-dispell from good sig is valid');
+is($@, '', 're-dispell from good sig doesn\'t croak');
+ok($res, 're-dispell from good sig is valid');
$res = eval { dispell my $b, $wiz };
-ok(!$@, "dispell non-magic object doesn't croak ($@)");
+is($@, '', 'dispell non-magic object doesn\'t croak');
is($res, 0, 'dispell non-magic object returns 0');
$sig = gensig;
}
my $c = 3;
$res = eval { cast $c, $sig };
-ok(!$@, "cast from obsolete signature doesn't croak ($@)");
-ok(!defined($res), 'cast from obsolete signature returns undef');
+is($@, '', 'cast from obsolete signature doesn\'t croak');
+is($res, undef, 'cast from obsolete signature returns undef');
$res = eval { cast $c, undef };
-ok($@, "cast from undef croaks ($@)");
-ok(!defined($res), 'cast from undef returns undef');
+like($@, qr/Invalid\s+numeric\s+signature/, 'cast from undef croaks');
+is($res, undef, 'cast from undef doesn\'t return anything');
}
eval { $w[0] = wizard get => sub { ++$c[0] }, set => sub { --$c[0] } };
-ok(!$@, "wizard 0 creation error ($@)");
+is($@, '', 'wizard 0 creation doesn\'t croak');
eval { $w[1] = wizard get => sub { ++$c[1] }, set => sub { --$c[1] } };
-ok(!$@, "wizard 1 creation error ($@)");
+is($@, '', 'wizard 1 creation doesn\'t croak');
eval { $w[2] = wizard get => sub { ++$c[2] }, set => sub { --$c[2] } };
-ok(!$@, "wizard 2 creation error ($@)");
+is($@, '', 'wizard 2 creation doesn\'t croak');
multi sub {
my ($i) = @_;
cast $a, $w[$i];
}, sub {
my ($i, $res, $err) = @_;
- ok(!$err, "cast magic $i doesn't croak ($err)");
- ok($res, "cast magic $i is valid");
+ is($err, '', "cast magic $i doesn't croak");
+ ok($res, "cast magic $i is valid");
};
my $b = $a;
for (0 .. $n - 1) { is($c[$_], 0, "set magic $_"); }
my $res = eval { dispell $a, $w[1] };
-ok(!$@, "dispell magic 1 doesn't croak ($@)");
-ok($res, 'dispell magic 1 is valid');
+is($@, '', 'dispell magic 1 doesn\'t croak');
+ok($res, 'dispell magic 1 is valid');
$b = $a;
for (0, 2) { is($c[$_], 1, "get magic $_ after dispelled 1"); }
for (0, 2) { is($c[$_], 0, "set magic $_ after dispelled 1"); }
$res = eval { dispell $a, $w[0] };
-ok(!$@, "dispell magic 0 doesn't croak ($@)");
-ok($res, 'dispell magic 0 is valid');
+is($@, '', 'dispell magic 0 doesn\'t croak');
+ok($res, 'dispell magic 0 is valid');
$b = $a;
is($c[2], 1, 'get magic 2 after dispelled 1 & 0');
is($c[2], 0, 'set magic 2 after dispelled 1 & 0');
$res = eval { dispell $a, $w[2] };
-ok(!$@, "dispell magic 2 doesn't croak ($@)");
-ok($res, 'dispell magic 2 is valid');
+is($@, '', 'dispell magic 2 doesn\'t croak');
+ok($res, 'dispell magic 2 is valid');
SKIP: {
skip 'No nice uvar magic for this perl', 41 unless VMG_UVAR;
@c = (0) x $n;
eval { $w[0] = wizard fetch => sub { ++$c[0] }, store => sub { --$c[0] } };
- ok(!$@, "wizard with uvar 0 creation error ($@)");
+ is($@, '', 'wizard with uvar 0 doesn\'t croak');
eval { $w[1] = wizard fetch => sub { ++$c[1] }, store => sub { --$c[1] } };
- ok(!$@, "wizard with uvar 1 creation error ($@)");
+ is($@, '', 'wizard with uvar 1 doesn\'t croak');
eval { $w[2] = wizard fetch => sub { ++$c[2] }, store => sub { --$c[2] } };
- ok(!$@, "wizard with uvar 2 creation error ($@)");
+ is($@, '', 'wizard with uvar 2 doesn\'t croak');
multi sub {
my ($i) = @_;
cast %h, $w[$i];
}, sub {
my ($i, $res, $err) = @_;
- ok(!$err, "cast uvar magic $i doesn't croak ($err)");
- ok($res, "cast uvar magic $i is valid");
+ is($err, '', "cast uvar magic $i doesn't croak");
+ ok($res, "cast uvar magic $i is valid");
};
my $s = $h{a};
# $c[$_] == 1 for 0 .. 2
my $res = eval { dispell %h, $w[1] };
- ok(!$@, "dispell uvar magic 1 doesn't croak ($@)");
- ok($res, 'dispell uvar magic 1 is valid');
+ is($@, '', 'dispell uvar magic 1 doesn\'t croak');
+ ok($res, 'dispell uvar magic 1 is valid');
$s = $h{b};
is($s, 2, 'fetch magic after dispelled 1 doesn\'t clobber');
# $c[$_] == 2 for 0, 2
$res = eval { dispell %h, $w[2] };
- ok(!$@, "dispell uvar magic 2 doesn't croak ($@)");
- ok($res, 'dispell uvar magic 2 is valid');
+ is($@, '', 'dispell uvar magic 2 doesn\'t croak');
+ ok($res, 'dispell uvar magic 2 is valid');
$s = $h{b};
is($s, 4, 'fetch magic after dispelled 1,2 doesn\'t clobber');
# $c[$_] == 3 for 0
$res = eval { dispell %h, $w[0] };
- ok(!$@, "dispell uvar magic 0 doesn't croak ($@)");
- ok($res, 'dispell uvar magic 0 is valid');
+ is($@, '', 'dispell uvar magic 0 doesn\'t croak');
+ ok($res, 'dispell uvar magic 0 is valid');
$s = $h{b};
is($s, 6, 'fetch magic after dispelled 1,2,0 doesn\'t clobber');
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More tests => 26;
use Variable::Magic qw/wizard getsig cast dispell SIG_MIN/;
{
my $wiz = eval { wizard sig => $sig };
- ok(!$@, "wizard creation doesn't croak ($@)");
- ok(defined $wiz, 'wizard is defined');
+ is($@, '', 'wizard creation doesn\'t croak');
+ ok(defined $wiz, 'wizard is defined');
is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
- is($sig, getsig $wiz, 'wizard signature is correct');
+ is($sig, getsig $wiz, 'wizard signature is correct');
my $wiz2 = eval { wizard sig => $sig };
- ok(!$@, "wizard retreive doesn't croak ($@)");
- ok(defined $wiz2, 'retrieved wizard is defined');
+ is($@, '', 'wizard retreive doesn\'t croak');
+ ok(defined $wiz2, 'retrieved wizard is defined');
is(ref $wiz2, 'SCALAR', 'retrieved wizard is a scalar ref');
- is($sig, getsig $wiz2, 'retrieved wizard signature is correct');
+ is($sig, getsig $wiz2, 'retrieved wizard signature is correct');
+
+ my $wiz3 = eval { wizard sig => [ ] };
+ like($@, qr/Invalid\s+numeric\s+signature/, 'non numeric signature croaks');
+ is($wiz3, undef, 'non numeric signature doesn\'t return anything');
my $a = 1;
my $res = eval { cast $a, $wiz };
- ok(!$@, "cast from wizard croaks ($@)");
- ok($res, 'cast from wizard invalid');
+ is($@, '', 'cast from wizard doesn\'t croak');
+ ok($res, 'cast from wizard invalid');
$res = eval { dispell $a, $wiz2 };
- ok(!$@, "dispell from retrieved wizard croaks ($@)");
- ok($res, 'dispell from retrieved wizard invalid');
+ is($@, '', 'dispell from retrieved wizard doesn\'t croak');
+ ok($res, 'dispell from retrieved wizard invalid');
$res = eval { cast $b, $sig };
- ok(!$@, "cast from integer croaks ($@)");
- ok($res, 'cast from integer invalid');
+ is($@, '', 'cast from integer doesn\'t croak');
+ ok($res, 'cast from integer invalid');
}
my $res = eval { cast $c, $sig + 0.1 };
-ok(!$@, "cast from float croaks ($@)");
-ok($res, 'cast from float invalid');
+is($@, '', 'cast from float doesn\'t croak');
+ok($res, 'cast from float invalid');
$res = eval { cast $d, sprintf "%u", $sig };
-ok(!$@, "cast from string croaks ($@)");
-ok($res, 'cast from string invalid');
+is($@, '', 'cast from string doesn\'t croak');
+ok($res, 'cast from string invalid');
$res = eval { dispell $b, $sig };
-ok(!$@, "dispell from integer croaks ($@)");
-ok($res, 'dispell from integer invalid');
+is($@, '', 'dispell from integer doesn\'t croak');
+ok($res, 'dispell from integer invalid');
$res = eval { dispell $c, $sig + 0.1 };
-ok(!$@, "dispell from float croaks ($@)");
-ok($res, 'dispell from float invalid');
+is($@, '', 'dispell from float doesn\'t croak');
+ok($res, 'dispell from float invalid');
$res = eval { dispell $d, sprintf "%u", $sig };
-ok(!$@, "dispell from string croaks ($@)");
-ok($res, 'dispell from string invalid');
+is($@, '', 'dispell from string doesn\'t croak');
+ok($res, 'dispell from string invalid');
get => sub { $c += $_[1]->{foo}; $_[1]->{foo} = $c },
set => sub { $c += $_[1]->{bar}; $_[1]->{bar} = $c }
};
-ok(!$@, "wizard doesn't croak ($@)");
+is($@, '', 'wizard doesn\'t croak');
ok(defined $wiz, 'wizard is defined');
is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
my $a = 75;
my $res = eval { cast $a, $wiz };
-ok(!$@, "cast does't croak ($@)");
-ok($res, 'cast returns true');
+is($@, '', 'cast doesn\'t croak');
+ok($res, 'cast returns true');
my $data = eval { getdata $a, $wiz };
-ok(!$@, "getdata from wizard doesn't croak ($@)");
-ok($res, 'getdata from wizard returns true');
+is($@, '', 'getdata from wizard doesn\'t croak');
+ok($res, 'getdata from wizard returns true');
is_deeply($data, { foo => 12, bar => 27 },
- 'getdata from wizard return value is ok');
+ 'getdata from wizard return value is ok');
$data = eval { getdata my $b, $wiz };
-ok(!$@, "getdata from non-magical scalar doesn't croak ($@)");
-ok(!defined($data), 'getdata from non-magical scalar returns undef');
+is($@, '', 'getdata from non-magical scalar doesn\'t croak');
+is($data, undef, 'getdata from non-magical scalar returns undef');
$data = eval { getdata $a, $sig };
-ok(!$@, "getdata from sig doesn't croak ($@)");
-ok($res, 'getdata from sig returns true');
+is($@, '', 'getdata from sig doesn\'t croak');
+ok($res, 'getdata from sig returns true');
is_deeply($data, { foo => 12, bar => 27 },
- 'getdata from sig return value is ok');
+ 'getdata from sig return value is ok');
my $b = $a;
is($c, 13, 'get magic : pass data');
is($data->{bar}, 40, 'set magic : pass data');
$data = eval { getdata $a, ($sig + 1) };
-ok(!$@, "getdata from invalid sig doesn't croak ($@)");
-ok(!defined($data), 'getdata from invalid sig returns undef');
+is($@, '', 'getdata from invalid sig doesn\'t croak');
+is($data, undef, 'getdata from invalid sig returns undef');
$data = eval { getdata $a, undef };
-ok($@, "getdata from undef croaks ($@)");
-ok(!defined($data), 'getdata from undef returns undef');
+like($@, qr/Invalid\s+wizard\s+object/, 'getdata from undef croaks');
+is($data, undef, 'getdata from undef doesn\'t return anything');
$res = eval { dispell $a, $wiz };
-ok(!$@, "dispell doesn't croak ($@)");
-ok($res, 'dispell returns true');
+is($@, '', 'dispell doesn\'t croak');
+ok($res, 'dispell returns true');
$res = eval { cast $a, $wiz, qw/z j t/ };
-ok(!$@, "cast with arguments doesn't croak ($@)");
-ok($res, 'cast with arguments returns true');
+is($@, '', 'cast with arguments doesn\'t croak');
+ok($res, 'cast with arguments returns true');
$data = eval { getdata $a, $wiz };
-ok(!$@, "getdata from wizard with arguments doesn't croak ($@)");
-ok($res, 'getdata from wizard with arguments returns true');
+is($@, '', 'getdata from wizard with arguments doesn\'t croak');
+ok($res, 'getdata from wizard with arguments returns true');
is_deeply($data, { foo => 'z', bar => 't' },
- 'getdata from wizard with arguments return value is ok');
+ 'getdata from wizard with arguments return value is ok');
$wiz = wizard get => sub { };
dispell $a, $sig;
$a = 63;
$res = eval { cast $a, $wiz };
-ok(!$@, "cast non-data wizard doesn't croak ($@)");
-ok($res, 'cast non-data wizard returns true');
+is($@, '', 'cast non-data wizard doesn\'t croak');
+ok($res, 'cast non-data wizard returns true');
$data = eval { getdata $a, $wiz };
-ok(!$@, "getdata from non-data wizard doesn't croak ($@)");
-ok(!defined($data), 'getdata from non-data wizard invalid returns undef');
+is($@, '', 'getdata from non-data wizard doesn\'t croak');
+is($data, undef, 'getdata from non-data wizard invalid returns undef');
use Variable::Magic qw/wizard cast/;
my $wiz = eval { wizard get => sub { undef } };
-ok(!$@, "wizard creation doesn't croak ($@)");
-ok(defined $wiz, 'wizard is defined');
+is($@, '', 'wizard creation doesn\'t croak');
+ok(defined $wiz, 'wizard is defined');
is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
my $n = int rand 1000;
my $a = $n;
my $res = eval { cast $a, $wiz };
-ok(!$@, "cast doesn't croak ($@)");
-ok($res, 'cast is valid');
+is($@, '', 'cast doesn\'t croak');
+ok($res, 'cast is valid');
my $x;
eval {
local $SIG{__WARN__} = sub { die };
$x = $a
};
-ok(!$@, 'callback returning undef doesn\'t warn/croak');
+is($@, '', 'callback returning undef doesn\'t warn/croak');
is($x, $n, 'callback returning undef fails');
get => sub { ++$c },
free => sub { --$c }
};
- ok(!$@, "wizard creation error ($@)");
- ok(defined $wiz, 'wizard is defined');
+ is($@, '', 'wizard creation error doesn\'t croak');
+ ok(defined $wiz, 'wizard is defined');
is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
my $res = eval { cast $wiz, $wiz };
- ok(!$@, "cast on self doesn't croak ($@)");
- ok($res, 'cast on self is valid');
+ is($@, '', 'cast on self doesn\'t croak');
+ ok($res, 'cast on self is valid');
my $w = $wiz;
is($c, 1, 'magic works correctly on self');
$res = eval { dispell $wiz, $wiz };
- ok(!$@, "dispell on self doesn't croak ($@)");
- ok($res, 'dispell on self is valid');
+ is($@, '', 'dispell on self doesn\'t croak');
+ ok($res, 'dispell on self is valid');
$w = $wiz;
is($c, 1, 'magic is no longer invoked on self when dispelled');
$res = eval { cast $wiz, $wiz, $wiz };
- ok(!$@, "re-cast on self doesn't croak ($@)");
- ok($res, 're-cast on self is valid');
+ is($@, '', 're-cast on self doesn\'t croak');
+ ok($res, 're-cast on self is valid');
$w = getdata $wiz, $wiz;
is($c, 1, 'getdata on magical self doesn\'t trigger callbacks');
# is(getsig($w), getsig($wiz), 'getdata returns the correct wizard');
$res = eval { dispell $wiz, $wiz };
- ok(!$@, "re-dispell on self doesn't croak ($@)");
- ok($res, 're-dispell on self is valid');
+ is($@, '', 're-dispell on self doesn\'t croak');
+ ok($res, 're-dispell on self is valid');
$res = eval { cast $wiz, $wiz };
- ok(!$@, "re-re-cast on self doesn't croak ($@)");
- ok($res, 're-re-cast on self is valid');
+ is($@, '', 're-re-cast on self doesn\'t croak');
+ ok($res, 're-re-cast on self is valid');
}
# is($c, 0, 'magic destructor is called');
my ($w, $c) = (undef, 0);
eval { $w = wizard fetch => sub { ++$c }, store => sub { --$c } };
-ok(!$@, "wizard with uvar doesn't croak ($@)");
+is($@, '', 'wizard with uvar doesn\'t croak');
ok(defined $w, 'wizard with uvar is defined');
is(ref $w, 'SCALAR', 'wizard with uvar is a scalar ref');
my $res = eval { cast %h, $w };
-ok(!$@, "cast uvar magic on fieldhash doesn't croak ($@)");
-ok($res, 'cast uvar magic on fieldhash is valid');
+is($@, '', 'cast uvar magic on fieldhash doesn\'t croak');
+ok($res, 'cast uvar magic on fieldhash is valid');
my $s = $h{$obj};
is($s, 5, 'fetch magic on fieldhash doesn\'t clobber');
is($h{$obj}, 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
$res = eval { dispell %h, $w };
-ok(!$@, "dispell uvar magic on fieldhash doesn't croak ($@)");
-ok($res, 'dispell uvar magic on fieldhash is valid');
+is($@, '', 'dispell uvar magic on fieldhash doesn\'t croak');
+ok($res, 'dispell uvar magic on fieldhash is valid');
$h{$obj} = 11;
$s = $h{$obj};
local $SIG{__WARN__} = sub { die };
$x = $h2{a};
};
-ok(!$@, 'uvar : fetch with incomplete magic');
+is($@, '', 'uvar : fetch with incomplete magic');
is($x, 37, 'uvar : fetch with incomplete magic correctly');
eval {
local $SIG{__WARN__} = sub { die };
$h2{a} = 73;
};
-ok(!$@, 'uvar : store with incomplete magic');
+is($@, '', 'uvar : store with incomplete magic');
is($h2{a}, 73, 'uvar : store with incomplete magic correctly');
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 14;
use Variable::Magic qw/wizard cast dispell/;
check('code : create wizard');
my $x = 0;
-my $n = sub { ++$x };
-my $a = $n;
+sub hlagh { ++$x };
-cast $a, $wiz;
+cast &hlagh, $wiz;
check('code : cast');
-my $b = $a;
-++$x[0];
-check('code : assign to');
+hlagh();
+check('code : call without arguments');
+is($x, 1, 'code : call without arguments succeeded');
-$b = "X${a}Y";
-++$x[0];
-check('code : interpolate');
+hlagh(1, 2, 3);
+check('code : call with arguments');
+is($x, 2, 'code : call with arguments succeeded');
-$b = \$a;
-check('code : reference');
+undef *hlagh;
+++$x[4];
+check('code : undef symbol table');
+is($x, 2, 'code : undef symbol table didn\'t call');
-$a = $n;
-++$x[1];
-check('code : assign');
+my $y = 0;
+*hlagh = sub { ++$y };
-$a->();
-check('code : call');
+cast &hlagh, $wiz;
+check('code : re-cast');
-{
- my $b = $n;
- cast $b, $wiz;
-}
-++$x[4];
-check('code : scope end');
+my $r = \&hlagh;
+check('code : take reference');
-undef $a;
-++$x[1];
-check('code : undef');
+$r->();
+check('code : call reference');
+is($y, 1, 'code : call reference succeeded');
+is($x, 2, 'code : call reference didn\'t triggered the previous code');
-dispell $a, $wiz;
+dispell &hlagh, $wiz;
check('code : dispell');
projects / perl / modules / Variable-Magic.git / commitdiff