Revision history for Variable-Magic
+0.13 2008-03-19 14:35 UTC
+ + Doc : Link to coverage report.
+ + Fix : Correct dependencies listing in META.yml.
+ + Tst : Improved test coverage.
+ + Tst : Print the patchlevel as a comment.
+ + Tst : Use is() where it's relevant.
+ + Tst : t/16-huf.t now really tests interaction with H::U::FH.
+
0.12 2008-02-07 18:15 UTC
+ Fix : POD error. Thanks to Chris Williams (BinGOs) for the quick
feedback.
--- #YAML:1.0
name: Variable-Magic
-version: 0.12
+version: 0.13
abstract: Associate user-defined magic to variables from Perl.
license: perl
author:
- Vincent Pit <perl@profvince.com>
-generated_by: ExtUtils::MakeMaker version 6.42
+generated_by: ExtUtils::MakeMaker version 6.44
distribution_type: module
requires:
Carp: 0
Exporter: 0
- Test::More: 0
XSLoader: 0
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
+build_requires:
+ Config: 0
+ ExtUtils::MakeMaker: 0
+ Test::More: 0
use warnings;
use ExtUtils::MakeMaker;
-eval {
- require Config;
-};
-die "OS unsupported" if $@;
+BEGIN {
+ eval { require Config };
+ die 'OS unsupported' if $@;
+ Config->import(qw/%Config/);
+}
my @DEFINES;
-
-my $pl = $Config::Config{perl_patchlevel};
+my $pl = $Config{perl_patchlevel};
print "Checking perl patchlevel... ";
if (defined $pl && length $pl) {
$pl = int $pl;
print "none\n";
}
+my $BUILD_REQUIRES = {
+ 'Config' => 0,
+ 'ExtUtils::MakeMaker' => 0,
+ 'Test::More' => 0,
+};
+
+sub build_req {
+ my $tometa = ' >> $(DISTVNAME)/META.yml;';
+ my $build_req = 'echo "build_requires:" ' . $tometa;
+ foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) {
+ my $ver = $BUILD_REQUIRES->{$mod};
+ $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa;
+ }
+ return $build_req;
+}
+
WriteMakefile(
- NAME => 'Variable::Magic',
- AUTHOR
=> 'Vincent Pit <perl@profvince.com>',
- LICENSE => 'perl',
- VERSION_FROM => 'lib/Variable/Magic.pm',
- ABSTRACT_FROM => 'lib/Variable/Magic.pm',
- PL_FILES => {},
+ NAME => 'Variable::Magic',
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ LICENSE => 'perl',
+ VERSION_FROM => 'lib/Variable/Magic.pm',
+ ABSTRACT_FROM => 'lib/Variable/Magic.pm',
+ PL_FILES => {},
@DEFINES,
- PREREQ_PM => {
- 'Carp' => 0,
- 'Exporter' => 0,
- 'Test::More' => 0,
- 'XSLoader' => 0
+ PREREQ_PM => {
+ 'Carp' => 0,
+ 'Exporter' => 0,
+ 'XSLoader' => 0
},
- dist => {
- PREOP => 'pod2text lib/Variable/Magic.pm > $(DISTVNAME)/README',
- COMPRESS => 'gzip -9f', SUFFIX => 'gz'
+ dist => {
+ PREOP => 'pod2text lib/Variable/Magic.pm > $(DISTVNAME)/README; '
+ . build_req,
+ COMPRESS => 'gzip -9f', SUFFIX => 'gz'
},
- clean => { FILES => 'Variable-Magic-*' },
+ clean => { FILES => 'Variable-Magic-* *.gcov *.gcda *.gcno cover_db' },
);
Variable::Magic - Associate user-defined magic to variables from Perl.
VERSION
- Version 0.12
+ Version 0.13
SYNOPSIS
use Variable::Magic qw/wizard cast dispell/;
perltie and overload for other ways of enhancing objects.
AUTHOR
- Vincent Pit, "<perl at profvince.com>"
+ Vincent Pit, "<perl at profvince.com>", <http://www.profvince.com>.
- You can contact me by mail or on #perl @ FreeNode (Prof_Vince).
+ You can contact me by mail or on #perl @ FreeNode (vincent or
+ Prof_Vince).
BUGS
Please report any bugs or feature requests to "bug-variable-magic at
perldoc Variable::Magic
+ Tests code coverage report is available at
+ <http://www.profvince.com/perl/cover/Variable-Magic>.
+
COPYRIGHT & LICENSE
Copyright 2007-2008 Vincent Pit, all rights reserved.
=head1 VERSION
-Version 0.12
+Version 0.13
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.12';
+ $VERSION = '0.13';
}
=head1 SYNOPSIS
=head1 AUTHOR
-Vincent Pit, C<< <perl at profvince.com> >>
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
-You can contact me by mail or on #perl @ FreeNode (Prof_Vince).
+You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
=head1 BUGS
-Please report any bugs or feature requests to
-C<bug-variable-magic at rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Variable-Magic>.
-I will be notified, and then you'll automatically be notified of progress on
-your bug as I make changes.
+Please report any bugs or feature requests to C<bug-variable-magic at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Variable-Magic>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
perldoc Variable::Magic
+Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Variable-Magic>.
+
=head1 COPYRIGHT & LICENSE
Copyright 2007-2008 Vincent Pit, all rights reserved.
use strict;
use warnings;
+use Config;
+
use Test::More tests => 1;
BEGIN {
use_ok( 'Variable::Magic' );
}
-diag( "Testing Variable::Magic $Variable::Magic::VERSION, Perl $], $^X" );
+my $p = $Config::Config{perl_patchlevel};
+$p = $p ? 'patchlevel ' . int $p : 'no patchlevel';
+diag( "Testing Variable::Magic $Variable::Magic::VERSION, Perl $] ($p), $^X" );
use strict;
use warnings;
-use Test::More tests => 16;
+use Test::More tests => 46;
-use Variable::Magic qw/wizard gensig getsig cast dispell/;
+use Variable::Magic qw/wizard gensig getsig cast dispell MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/;
+
+my $args = 7;
+++$args if MGf_COPY;
+++$args if MGf_DUP;
+++$args if MGf_LOCAL;
+$args += 4 if VMG_UVAR;
+for (0 .. 20) {
+ next if $_ == $args;
+ eval { Variable::Magic::_wizard(('hlagh') x $_) };
+ ok($@, "_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 ($@)");
+}
my $sig = gensig;
my $wiz = eval { wizard sig => $sig };
-ok(!$@, "wizard creation error ($@)");
-ok(defined $wiz, 'wizard is defined');
-ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref');
-ok($sig == getsig $wiz, 'wizard signature is correct');
+ok(!$@, "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 croaks ($@)");
-ok($res, 'cast invalid');
+ok(!$@, "cast doesn't croak ($@)");
+ok($res, 'cast is valid');
$res = eval { dispell $a, $wiz };
-ok(!$@, "dispell from wizard croaks ($@)");
-ok($res, 'dispell from wizard invalid');
+ok(!$@, "dispell from wizard doesn't croak ($@)");
+ok($res, 'dispell from wizard is valid');
$res = eval { cast $a, $wiz };
-ok(!$@, "re-cast croaks ($@)");
-ok($res, 're-cast invalid');
+ok(!$@, "re-cast doesn't croak ($@)");
+ok($res, 're-cast is valid');
-$res = eval { dispell $a, $wiz };
-ok(!$@, "re-dispell croaks ($@)");
-ok($res, 're-dispell invalid');
+$res = eval { dispell $a, gensig };
+ok(!$@, "re-dispell from wrong sig doesn't croak ($@)");
+ok(!defined($res), 're-dispell from wrong sig returns undef');
+
+$res = eval { dispell $a, undef };
+ok($@, "re-dispell from undef croaks ($@)");
+ok(!defined($res), 're-dispell from undef returns undef');
+
+$res = eval { dispell $a, $sig };
+ok(!$@, "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 fails ($@)");
-ok($res == 0, 'dispell non-magic object doesn\'t return 0');
+ok(!$@, "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 croaks ($@)");
+ok(!$@, "cast from obsolete signature doesn't croak ($@)");
ok(!defined($res), 'cast from obsolete signature returns undef');
+
+$res = eval { cast $c, undef };
+ok($@, "cast from undef croaks ($@)");
+ok(!defined($res), 'cast from undef returns undef');
use strict;
use warnings;
-use Test::More tests => 33 + 24;
+use Test::More tests => 33 + 41;
use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
$w[$i]
}, sub {
my ($i, $res, $err) = @_;
- ok(defined $res, "wizard $i is defined");
- ok(ref($w[$i]) eq 'SCALAR', "wizard $i is a scalar ref");
+ ok(defined $res, "wizard $i is defined");
+ is(ref $w[$i], 'SCALAR', "wizard $i is a scalar ref");
};
my $a = 0;
cast $a, $w[$i];
}, sub {
my ($i, $res, $err) = @_;
- ok(!$err, "cast magic $i croaks ($err)");
- ok($res, "cast magic $i invalid");
+ ok(!$err, "cast magic $i doesn't croak ($err)");
+ ok($res, "cast magic $i is valid");
};
my $b = $a;
-for (0 .. $n - 1) { ok($c[$_] == 1, "get magic $_"); }
+for (0 .. $n - 1) { is($c[$_], 1, "get magic $_"); }
$a = 1;
-for (0 .. $n - 1) { ok($c[$_] == 0, "set magic $_"); }
+for (0 .. $n - 1) { is($c[$_], 0, "set magic $_"); }
my $res = eval { dispell $a, $w[1] };
-ok(!$@, "dispell magic 1 croaks ($@)");
-ok($res, 'dispell magic 1 invalid');
+ok(!$@, "dispell magic 1 doesn't croak ($@)");
+ok($res, 'dispell magic 1 is valid');
$b = $a;
-for (0, 2) { ok($c[$_] == 1, "get magic $_ after dispelled 1"); }
+for (0, 2) { is($c[$_], 1, "get magic $_ after dispelled 1"); }
$a = 2;
-for (0, 2) { ok($c[$_] == 0, "set 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 croaks ($@)");
-ok($res, 'dispell magic 0 invalid');
+ok(!$@, "dispell magic 0 doesn't croak ($@)");
+ok($res, 'dispell magic 0 is valid');
$b = $a;
-ok($c[2] == 1, 'get magic 2 after dispelled 1 & 0');
+is($c[2], 1, 'get magic 2 after dispelled 1 & 0');
$a = 3;
-ok($c[2] == 0, 'set 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 croaks ($@)");
-ok($res, 'dispell magic 2 invalid');
+ok(!$@, "dispell magic 2 doesn't croak ($@)");
+ok($res, 'dispell magic 2 is valid');
SKIP: {
- skip 'No nice uvar magic for this perl', 24 unless VMG_UVAR;
+ skip 'No nice uvar magic for this perl', 41 unless VMG_UVAR;
- $n = 2;
+ $n = 3;
@c = (0) x $n;
eval { $w[0] = wizard fetch => sub { ++$c[0] }, store => sub { --$c[0] } };
ok(!$@, "wizard with uvar 0 creation error ($@)");
eval { $w[1] = wizard fetch => sub { ++$c[1] }, store => sub { --$c[1] } };
ok(!$@, "wizard with uvar 1 creation error ($@)");
+ eval { $w[2] = wizard fetch => sub { ++$c[2] }, store => sub { --$c[2] } };
+ ok(!$@, "wizard with uvar 2 creation error ($@)");
multi sub {
my ($i) = @_;
$w[$i]
}, sub {
my ($i, $res, $err) = @_;
- ok(defined $res, "wizard with uvar $i is defined");
- ok(ref($w[$i]) eq 'SCALAR', "wizard with uvar $i is a scalar ref");
+ ok(defined $res, "wizard with uvar $i is defined");
+ is(ref $w[$i], 'SCALAR', "wizard with uvar $i is a scalar ref");
};
my %h = (a => 1, b => 2);
cast %h, $w[$i];
}, sub {
my ($i, $res, $err) = @_;
- ok(!$err, "cast uvar magic $i croaks ($err)");
- ok($res, "cast uvar magic $i invalid");
+ ok(!$err, "cast uvar magic $i doesn't croak ($err)");
+ ok($res, "cast uvar magic $i is valid");
};
my $s = $h{a};
- ok($s == 1, 'fetch magic doesn\'t clobber');
- for (0 .. $n - 1) { ok($c[$_] == 1, "fetch magic $_"); }
+ is($s, 1, 'fetch magic doesn\'t clobber');
+ for (0 .. $n - 1) { is($c[$_], 1, "fetch magic $_"); }
$h{a} = 3;
- for (0 .. $n - 1) { ok($c[$_] == 0, "store magic $_"); }
- ok($h{a} == 3, 'store magic doesn\'t clobber'); # $c[$_] == 1 for 0 .. 1
+ for (0 .. $n - 1) { is($c[$_], 0, "store magic $_"); }
+ is($h{a}, 3, 'store magic doesn\'t clobber');
+ # $c[$_] == 1 for 0 .. 2
my $res = eval { dispell %h, $w[1] };
- ok(!$@, "dispell uvar magic 1 croaks ($@)");
- ok($res, 'dispell uvar magic 1 invalid');
+ ok(!$@, "dispell uvar magic 1 doesn't croak ($@)");
+ ok($res, 'dispell uvar magic 1 is valid');
$s = $h{b};
- ok($s == 2, 'fetch magic after dispelled 1 doesn\'t clobber');
- for (0) { ok($c[$_] == 2, "fetch magic $_ after dispelled 1"); }
+ is($s, 2, 'fetch magic after dispelled 1 doesn\'t clobber');
+ for (0, 2) { is($c[$_], 2, "fetch magic $_ after dispelled 1"); }
$h{b} = 4;
- for (0) { ok($c[$_] == 1, "store magic $_ after dispelled 1"); }
- ok($h{b} == 4, 'store magic doesn\'t clobber'); # $c[$_] == 2 for 0
+ for (0, 2) { is($c[$_], 1, "store magic $_ after dispelled 1"); }
+ is($h{b}, 4, 'store 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');
+
+ $s = $h{b};
+ is($s, 4, 'fetch magic after dispelled 1,2 doesn\'t clobber');
+ for (0) { is($c[$_], 3, "fetch magic $_ after dispelled 1,2"); }
+
+ $h{b} = 6;
+ for (0) { is($c[$_], 2, "store magic $_ after dispelled 1,2"); }
+ is($h{b}, 6, 'store magic after dispelled 1,2 doesn\'t clobber');
+ # $c[$_] == 3 for 0
$res = eval { dispell %h, $w[0] };
- ok(!$@, "dispell uvar magic 0 croaks ($@)");
- ok($res, 'dispell uvar magic 0 invalid');
+ ok(!$@, "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');
+ $h{b} = 8;
+ is($h{b}, 8, 'store magic after dispelled 1,2,0 doesn\'t clobber');
}
{
my $wiz = eval { wizard sig => $sig };
- ok(!$@, "wizard creation error ($@)");
+ ok(!$@, "wizard creation doesn't croak ($@)");
ok(defined $wiz, 'wizard is defined');
- ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref');
- ok($sig == getsig $wiz, 'wizard signature is correct');
+ is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
+ is($sig, getsig $wiz, 'wizard signature is correct');
my $wiz2 = eval { wizard sig => $sig };
- ok(!$@, "wizard retrieve error ($@)");
+ ok(!$@, "wizard retreive doesn't croak ($@)");
ok(defined $wiz2, 'retrieved wizard is defined');
- ok(ref $wiz2 eq 'SCALAR', 'retrieved wizard is a scalar ref');
- ok($sig == getsig $wiz2, 'retrieved wizard signature is correct');
+ is(ref $wiz2, 'SCALAR', 'retrieved wizard is a scalar ref');
+ is($sig, getsig $wiz2, 'retrieved wizard signature is correct');
my $a = 1;
my $res = eval { cast $a, $wiz };
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 32;
-use Variable::Magic qw/wizard getdata cast dispell/;
+use Variable::Magic qw/wizard getdata cast dispell SIG_MIN/;
my $c = 1;
+my $sig = SIG_MIN;
my $wiz = eval {
- wizard data => sub { return { foo => $_[1] || 12, bar => $_[3] || 27 } },
+ wizard sig => $sig,
+ data => sub { return { foo => $_[1] || 12, bar => $_[3] || 27 } },
get => sub { $c += $_[1]->{foo}; $_[1]->{foo} = $c },
set => sub { $c += $_[1]->{bar}; $_[1]->{bar} = $c }
};
-ok(!$@, "wizard creation error ($@)");
-ok(defined $wiz, 'wizard is defined');
-ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref');
+ok(!$@, "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 croaks ($@)");
-ok($res, 'cast invalid');
+ok(!$@, "cast does't croak ($@)");
+ok($res, 'cast returns true');
my $data = eval { getdata $a, $wiz };
-ok(!$@, "getdata croaks ($@)");
-ok($res, 'getdata invalid');
-ok($data && ref($data) eq 'HASH'
- && exists $data->{foo} && $data->{foo} == 12
- && exists $data->{bar} && $data->{bar} == 27,
- 'private data creation ok');
+ok(!$@, "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');
+
+$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');
+
+$data = eval { getdata $a, $sig };
+ok(!$@, "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');
my $b = $a;
-ok($c == 13, 'get magic : pass data');
-ok($data->{foo} == 13, 'get magic : data updated');
+is($c, 13, 'get magic : pass data');
+is($data->{foo}, 13, 'get magic : data updated');
$a = 57;
-ok($c == 40, 'set magic : pass data');
-ok($data->{bar} == 40, 'set magic : pass data');
+is($c, 40, 'set 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');
+
+$data = eval { getdata $a, undef };
+ok($@, "getdata from undef croaks ($@)");
+ok(!defined($data), 'getdata from undef returns undef');
$res = eval { dispell $a, $wiz };
-ok(!$@, "dispell croaks ($@)");
-ok($res, 'dispell invalid');
+ok(!$@, "dispell doesn't croak ($@)");
+ok($res, 'dispell returns true');
$res = eval { cast $a, $wiz, qw/z j t/ };
-ok(!$@, "cast with arguments croaks ($@)");
-ok($res, 'cast with arguments invalid');
+ok(!$@, "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_deeply($data, { foo => 'z', bar => 't' },
+ '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');
$data = eval { getdata $a, $wiz };
-ok(!$@, "getdata croaks ($@)");
-ok($res, 'getdata invalid');
-ok($data && ref($data) eq 'HASH'
- && exists $data->{foo} && $data->{foo} eq 'z'
- && exists $data->{bar} && $data->{bar} eq 't',
- 'private data creation with arguments ok');
+ok(!$@, "getdata from non-data wizard doesn't croak ($@)");
+ok(!defined($data), 'getdata from non-data wizard invalid returns undef');
use Variable::Magic qw/wizard cast/;
my $wiz = eval { wizard get => sub { undef } };
-ok(!$@, "wizard creation error ($@)");
+ok(!$@, "wizard creation doesn't croak ($@)");
ok(defined $wiz, 'wizard is defined');
-ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref');
+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 croaks ($@)");
-ok($res, 'cast invalid');
+ok(!$@, "cast doesn't croak ($@)");
+ok($res, 'cast is valid');
my $x;
eval {
local $SIG{__WARN__} = sub { die };
$x = $a
};
-ok(!$@, 'callback returning undef croaks');
-ok(defined($x) && ($x == $n), 'callback returning undef fails');
+ok(!$@, 'callback returning undef doesn\'t warn/croak');
+is($x, $n, 'callback returning undef fails');
};
ok(!$@, "wizard creation error ($@)");
ok(defined $wiz, 'wizard is defined');
- ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref');
+ is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
my $res = eval { cast $wiz, $wiz };
- ok(!$@, "cast on self croaks ($@)");
- ok($res, 'cast on self invalid');
+ ok(!$@, "cast on self doesn't croak ($@)");
+ ok($res, 'cast on self is valid');
my $w = $wiz;
- ok($c == 1, 'magic works correctly on self');
+ is($c, 1, 'magic works correctly on self');
$res = eval { dispell $wiz, $wiz };
- ok(!$@, "dispell on self croaks ($@)");
- ok($res, 'dispell on self invalid');
+ ok(!$@, "dispell on self doesn't croak ($@)");
+ ok($res, 'dispell on self is valid');
$w = $wiz;
- ok($c == 1, 'magic is no longer invoked on self when dispelled');
+ is($c, 1, 'magic is no longer invoked on self when dispelled');
$res = eval { cast $wiz, $wiz, $wiz };
- ok(!$@, "re-cast on self croaks ($@)");
- ok($res, 're-cast on self invalid');
+ ok(!$@, "re-cast on self doesn't croak ($@)");
+ ok($res, 're-cast on self is valid');
$w = getdata $wiz, $wiz;
- ok($c == 1, 'getdata on magical self doesn\'t trigger callbacks');
- # ok(getsig($w) == getsig($wiz), 'getdata returns the correct wizard');
+ 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 croaks ($@)");
- ok($res, 're-dispell on self invalid');
+ ok(!$@, "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 croaks ($@)");
- ok($res, 're-re-cast on self invalid');
+ ok(!$@, "re-re-cast on self doesn't croak ($@)");
+ ok($res, 're-re-cast on self is valid');
}
-# ok($c == 0, 'magic destructor is called');
+# is($c, 0, 'magic destructor is called');
plan skip_all => 'No nice uvar magic for this perl';
}
-eval "use Hash::Util::FieldHash qw/fieldhash/";
+eval "use Hash::Util::FieldHash";
if ($@) {
plan skip_all => 'Hash::Util::FieldHash required for testing uvar interaction';
} else {
plan tests => 12;
}
-fieldhash(my %h);
+Hash::Util::FieldHash::fieldhash(\my %h);
-bless \(my $obj = {}), 'Variable::Magic::Test::Mock';
+my $obj = { };
+bless $obj, 'Variable::Magic::Test::Mock';
$h{$obj} = 5;
my ($w, $c) = (undef, 0);
eval { $w = wizard fetch => sub { ++$c }, store => sub { --$c } };
-ok(!$@, "wizard with uvar creation error ($@)");
-ok(defined $w, 'wizard with uvar is defined');
-ok(ref($w) eq 'SCALAR', 'wizard with uvar is a scalar ref');
+ok(!$@, "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 croaks ($@)");
-ok($res, 'cast uvar magic on fieldhash invalid');
+ok(!$@, "cast uvar magic on fieldhash doesn't croak ($@)");
+ok($res, 'cast uvar magic on fieldhash is valid');
my $s = $h{$obj};
-ok($s == 5, 'fetch magic on fieldhash doesn\'t clobber');
-ok($c == 1, 'fetch magic on fieldhash');
+is($s, 5, 'fetch magic on fieldhash doesn\'t clobber');
+is($c, 1, 'fetch magic on fieldhash');
$h{$obj} = 7;
-ok($c == 0, 'store magic on fieldhash');
-ok($h{$obj} == 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
+is($c, 0, 'store magic on fieldhash');
+is($h{$obj}, 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
$res = eval { dispell %h, $w };
-ok(!$@, "dispell uvar magic on fieldhash croaks ($@)");
-ok($res, 'dispell uvar magic on fieldhash invalid');
+ok(!$@, "dispell uvar magic on fieldhash doesn't croak ($@)");
+ok($res, 'dispell uvar magic on fieldhash is valid');
$h{$obj} = 11;
$s = $h{$obj};
-ok($s == 11, 'store/fetch on fieldhash after dispell still ok');
+is($s, 11, 'store/fetch on fieldhash after dispell still ok');
my $c = 0;
my $wiz = wizard get => sub { ++$c };
-ok($c == 0, 'get : create wizard');
+is($c, 0, 'get : create wizard');
my $n = int rand 1000;
my $a = $n;
cast $a, $wiz;
-ok($c == 0, 'get : cast');
+is($c, 0, 'get : cast');
my $b = $a;
-ok($c == 1, 'get : assign to');
-ok($b == $n, 'get : assign to correctly');
+is($c, 1, 'get : assign to');
+is($b, $n, 'get : assign to correctly');
$b = "X${a}Y";
-ok($c == 2, 'get : interpolate');
-ok($b eq "X${n}Y", 'get : interpolate correctly');
+is($c, 2, 'get : interpolate');
+is($b, "X${n}Y", 'get : interpolate correctly');
my $c = 0;
my $wiz = wizard set => sub { ++$c };
-ok($c == 0, 'get : create wizard');
+is($c, 0, 'get : create wizard');
my $a = 0;
cast $a, $wiz;
-ok($c == 0, 'get : cast');
+is($c, 0, 'get : cast');
my $n = int rand 1000;
$a = $n;
-ok($c == 1, 'set : assign');
-ok($a == $n, 'set : assign correctly');
+is($c, 1, 'set : assign');
+is($a, $n, 'set : assign correctly');
++$a;
-ok($c == 2, 'set : increment');
-ok($a == $n + 1, 'set : increment correctly');
+is($c, 2, 'set : increment');
+is($a, $n + 1, 'set : increment correctly');
--$a;
-ok($c == 3, 'set : decrement');
-ok($a == $n, 'set : decrement correctly');
+is($c, 3, 'set : decrement');
+is($a, $n, 'set : decrement correctly');
my $c = 0;
my $n = int rand 1000;
my $wiz = wizard len => sub { ++$c; return $n };
-ok($c == 0, 'len : create wizard');
+is($c, 0, 'len : create wizard');
my @a = qw/a b c/;
cast @a, $wiz;
-ok($c == 0, 'len : cast');
+is($c, 0, 'len : cast');
my $b = scalar @a;
-ok($c == 1, 'len : get length');
-ok($b == $n, 'len : get length correctly');
+is($c, 1, 'len : get length');
+is($b, $n, 'len : get length correctly');
$n = 0;
$b = scalar @a;
-ok($c == 2, 'len : get length 0');
-ok($b == 0, 'len : get length 0 correctly');
+is($c, 2, 'len : get length 0');
+is($b, 0, 'len : get length 0 correctly');
my $c = 0;
my $wiz = wizard clear => sub { ++$c };
-ok($c == 0, 'clear : create wizard');
+is($c, 0, 'clear : create wizard');
my @a = qw/a b c/;
cast @a, $wiz;
-ok($c == 0, 'clear : cast array');
+is($c, 0, 'clear : cast array');
@a = ();
-ok($c == 1, 'clear : clear array');
+is($c, 1, 'clear : clear array');
ok(!defined $a[0], 'clear : clear array correctly');
my %h = (foo => 1, bar => 2);
cast %h, $wiz;
-ok($c == 1, 'clear : cast hash');
+is($c, 1, 'clear : cast hash');
%h = ();
-ok($c == 2, 'clear : clear hash');
+is($c, 2, 'clear : clear hash');
ok(!(keys %h), 'clear : clear hash correctly');
my $c = 0;
my $wiz = wizard free => sub { ++$c };
-ok($c == 0, 'free : create wizard');
+is($c, 0, 'free : create wizard');
my $n = int rand 1000;
my $a = $n;
cast $a, $wiz;
- ok($c == 0, 'free : cast');
+ is($c, 0, 'free : cast');
}
-ok($c == 1, 'free : deletion at the end of the scope');
+is($c, 1, 'free : deletion at the end of the scope');
my $a = $n;
undef $n;
-ok($c == 1, 'free : explicit deletion with undef()');
+is($c, 1, 'free : explicit deletion with undef()');
my $c = 0;
my $wiz = wizard 'copy' => sub { ++$c };
-ok($c == 0, 'copy : create wizard');
+is($c, 0, 'copy : create wizard');
SKIP: {
eval "use Tie::Array";
@a = (1 .. 10);
my $res = cast @a, $wiz;
- ok($res, 'copy : cast on array succeeded');
- ok($c == 0, 'copy : cast on array didn\'t triggered the callback');
+ ok($res, 'copy : cast on array succeeded');
+ is($c, 0, 'copy : cast on array didn\'t triggered the callback');
$a[3] = 13;
- ok($c == 1, 'copy : callback triggers on array store');
+ is($c, 1, 'copy : callback triggers on array store');
my $s = $a[3];
- ok($c == 2, 'copy : callback triggers on array fetch');
- ok($s == 13, 'copy : array fetch is correct');
+ is($c, 2, 'copy : callback triggers on array fetch');
+ is($s, 13, 'copy : array fetch is correct');
$s = exists $a[3];
- ok($c == 3, 'copy : callback triggers on array exists');
- ok($s, 'copy : array exists is correct');
+ is($c, 3, 'copy : callback triggers on array exists');
+ ok($s, 'copy : array exists is correct');
undef @a;
- ok($c == 3, 'copy : callback doesn\'t trigger on array undef');
+ is($c, 3, 'copy : callback doesn\'t trigger on array undef');
}
SKIP: {
$c = 0;
my $res = cast %h, $wiz;
- ok($res, 'copy : cast on hash succeeded');
- ok($c == 0, 'copy : cast on hash didn\'t triggered the callback');
+ ok($res, 'copy : cast on hash succeeded');
+ is($c, 0, 'copy : cast on hash didn\'t triggered the callback');
$h{b} = 7;
- ok($c == 1, 'copy : callback triggers on hash store');
+ is($c, 1, 'copy : callback triggers on hash store');
my $s = $h{c};
- ok($c == 2, 'copy : callback triggers on hash fetch');
- ok($s == 3, 'copy : hash fetch is correct');
+ is($c, 2, 'copy : callback triggers on hash fetch');
+ is($s, 3, 'copy : hash fetch is correct');
$s = exists $h{a};
- ok($c == 3, 'copy : callback triggers on hash exists');
- ok($s, 'copy : hash exists is correct');
+ is($c, 3, 'copy : callback triggers on hash exists');
+ ok($s, 'copy : hash exists is correct');
$s = delete $h{b};
- ok($c == 4, 'copy : callback triggers on hash delete');
- ok($s == 7, 'copy : hash delete is correct');
+ is($c, 4, 'copy : callback triggers on hash delete');
+ is($s, 7, 'copy : hash delete is correct');
my ($k, $v) = each %h;
- ok($c == 5, 'copy : callback triggers on hash each');
+ is($c, 5, 'copy : callback triggers on hash each');
my @k = keys %h;
- ok($c == 5, 'copy : callback doesn\'t trigger on hash keys');
+ is($c, 5, 'copy : callback doesn\'t trigger on hash keys');
my @v = values %h;
- ok(@v == 2, 'copy : two values in the hash');
- ok($c == 7, 'copy : callback triggers on hash values');
+ is(scalar @v, 2, 'copy : two values in the hash');
+ is($c, 7, 'copy : callback triggers on hash values');
undef %h;
- ok($c == 7, 'copy : callback doesn\'t trigger on hash undef');
+ is($c, 7, 'copy : callback doesn\'t trigger on hash undef');
}
my $c = 0;
my $wiz = wizard 'local' => sub { ++$c };
-ok($c == 0, 'local : create wizard');
+is($c, 0, 'local : create wizard');
local $a = int rand 1000;
my $res = cast $a, $wiz;
-ok($res, 'local : cast succeeded');
-ok($c == 0, 'local : cast didn\'t triggered the callback');
+ok($res, 'local : cast succeeded');
+is($c, 0, 'local : cast didn\'t triggered the callback');
{
local $a;
- ok($c == 1, 'local : localized');
+ is($c, 1, 'local : localized');
}
-ok($c == 1, 'local : end of local scope');
+is($c, 1, 'local : end of local scope');
my @x = (0) x 4;
sub check {
- for (0 .. 3) { return 0 unless $c[$_] == $x[$_]; }
- return 1;
+ is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 3]),
+ join(':', map { (defined) ? $_ : 'u' } @x[0 .. 3]),
+ $_[0];
}
my $wiz = wizard 'fetch' => sub { ++$c[0] },
'store' => sub { ++$c[1] },
'exists' => sub { ++$c[2] },
'delete' => sub { ++$c[3] };
-ok(check(), 'uvar : create wizard');
+check('uvar : create wizard');
my %h = (a => 1, b => 2, c => 3);
my $res = cast %h, $wiz;
-ok($res, 'uvar : cast succeeded');
-ok(check(), 'uvar : cast didn\'t triggered the callback');
+ok($res, 'uvar : cast succeeded');
+check( 'uvar : cast didn\'t triggered the callback');
my $x = $h{a};
++$x[0];
-ok(check(), 'uvar : fetch directly');
-ok($x, 'uvar : fetch directly correctly');
+check( 'uvar : fetch directly');
+ok($x, 'uvar : fetch directly correctly');
$x = "$h{b}";
++$x[0];
-ok(check(), 'uvar : fetch by interpolation');
-ok($x == 2, 'uvar : fetch by interpolation correctly');
+check( 'uvar : fetch by interpolation');
+is($x, 2, 'uvar : fetch by interpolation correctly');
$h{c} = 4;
++$x[1];
-ok(check(), 'uvar : store directly');
+check('uvar : store directly');
$x = $h{c} = 5;
++$x[1];
-ok(check(), 'uvar : fetch and store');
-ok($x == 5, 'uvar : fetch and store correctly');
+check( 'uvar : fetch and store');
+is($x, 5, 'uvar : fetch and store correctly');
$x = exists $h{c};
++$x[2];
-ok(check(), 'uvar : exists');
-ok($x, 'uvar : exists correctly');
+check( 'uvar : exists');
+ok($x, 'uvar : exists correctly');
$x = delete $h{c};
++$x[3];
-ok(check(), 'uvar : delete existing key');
-ok($x == 5, 'uvar : delete existing key correctly');
+check( 'uvar : delete existing key');
+is($x, 5, 'uvar : delete existing key correctly');
$x = delete $h{z};
++$x[3];
-ok(check(), 'uvar : delete non-existing key');
+check( 'uvar : delete non-existing key');
ok(!defined $x, 'uvar : delete non-existing key correctly');
my $wiz2 = wizard 'fetch' => sub { 0 };
local $SIG{__WARN__} = sub { die };
$x = $h2{a};
};
-ok(!$@, 'uvar : fetch with incomplete magic');
-ok($x == 37, 'uvar : fetch with incomplete magic correctly');
+ok(!$@, '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');
-ok($h2{a} == 73, 'uvar : store with incomplete magic correctly');
+ok(!$@, 'uvar : store with incomplete magic');
+is($h2{a}, 73, 'uvar : store with incomplete magic correctly');
my @x = (0) x 12;
sub check {
- for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
- return 1;
+ is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 11]),
+ join(':', map { (defined) ? $_ : 'u' } @x[0 .. 11]),
+ $_[0];
}
my $i = -1;
store => sub { ++$c[9] },
'exists' => sub { ++$c[10] },
'delete' => sub { ++$c[11] };
-ok(check(), 'scalar : create wizard');
+check('scalar : create wizard');
my $n = int rand 1000;
my $a = $n;
cast $a, $wiz;
-ok(check(), 'scalar : cast');
+check('scalar : cast');
my $b = $a;
++$x[0];
-ok(check(), 'scalar : assign to');
+check('scalar : assign to');
$b = "X${a}Y";
++$x[0];
-ok(check(), 'scalar : interpolate');
+check('scalar : interpolate');
$b = \$a;
-ok(check(), 'scalar : reference');
+check('scalar : reference');
$a = 123;
++$x[1];
-ok(check(), 'scalar : assign');
+check('scalar : assign');
++$a;
++$x[0]; ++$x[1];
-ok(check(), 'scalar : increment');
+check('scalar : increment');
--$a;
++$x[0]; ++$x[1];
-ok(check(), 'scalar : decrement');
+check('scalar : decrement');
$a *= 1.5;
++$x[0]; ++$x[1];
-ok(check(), 'scalar : multiply');
+check('scalar : multiply');
$a /= 1.5;
++$x[0]; ++$x[1];
-ok(check(), 'scalar : divide');
+check('scalar : divide');
{
my $b = $n;
cast $b, $wiz;
}
++$x[4];
-ok(check(), 'scalar : scope end');
+check('scalar : scope end');
undef $a;
++$x[1];
-ok(check(), 'scalar : undef');
+check('scalar : undef');
dispell $a, $wiz;
-ok(check(), 'scalar : dispell');
+check('scalar : dispell');
my @x = (0) x 12;
sub check {
- for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
- return 1;
+ is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 11]),
+ join(':', map { (defined) ? $_ : 'u' } @x[0 .. 11]),
+ $_[0];
}
my $wiz = wizard get => sub { ++$c[0] },
store => sub { ++$c[9] },
'exists' => sub { ++$c[10] },
'delete' => sub { ++$c[11] };
-ok(check(), 'array : create wizard');
+check('array : create wizard');
my @n = map { int rand 1000 } 1 .. 5;
my @a = @n;
cast @a, $wiz;
-ok(check(), 'array : cast');
+check('array : cast');
my $b = $a[2];
-ok(check(), 'array : assign element to');
+check('array : assign element to');
my @b = @a;
++$x[2];
-ok(check(), 'array : assign to');
+check('array : assign to');
$b = "X@{a}Y";
++$x[2];
-ok(check(), 'array : interpolate');
+check('array : interpolate');
$b = \@a;
-ok(check(), 'array : reference');
+check('array : reference');
@b = @a[2 .. 4];
-ok(check(), 'array : slice');
+check('array : slice');
@a = qw/a b d/;
$x[1] += 3; ++$x[3];
-ok(check(), 'array : assign');
+check('array : assign');
$a[2] = 'c';
-ok(check(), 'array : assign old element');
+check('array : assign old element');
$a[3] = 'd';
++$x[1];
-ok(check(), 'array : assign new element');
+check('array : assign new element');
push @a, 'x';
++$x[1]; ++$x[2] unless VMG_COMPAT_ARRAY_PUSH_NOLEN;
-ok(check(), 'array : push');
+check('array : push');
pop @a;
++$x[1]; ++$x[2];
-ok(check(), 'array : pop');
+check('array : pop');
unshift @a, 'x';
++$x[1]; ++$x[2];
-ok(check(), 'array : unshift');
+check('array : unshift');
shift @a;
++$x[1]; ++$x[2];
-ok(check(), 'array : shift');
+check('array : shift');
$b = @a;
++$x[2];
-ok(check(), 'array : length');
+check('array : length');
@a = map ord, @a;
$x[1] += 4; ++$x[2]; ++$x[3];
-ok(check(), 'array : map');
+check('array : map');
@b = grep { defined && $_ >= ord('b') } @a;
++$x[2];
-ok(check(), 'array : grep');
+check('array : grep');
for (@a) { }
$x[2] += 5;
-ok(check(), 'array : for');
+check('array : for');
{
my @b = @n;
cast @b, $wiz;
}
++$x[4];
-ok(check(), 'array : scope end');
+check('array : scope end');
undef @a;
++$x[3] if VMG_COMPAT_ARRAY_UNDEF_CLEAR;
-ok(check(), 'array : undef');
+check('array : undef');
dispell @a, $wiz;
-ok(check(), 'array : dispel');
+check('array : dispel');
my @x = (0) x 12;
sub check {
- for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
- return 1;
+ is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 11]),
+ join(':', map { (defined) ? $_ : 'u' } @x[0 .. 11]),
+ $_[0];
}
my $wiz = wizard get => sub { ++$c[0] },
store => sub { ++$c[9] },
'exists' => sub { ++$c[10] },
'delete' => sub { ++$c[11] };
-ok(check(), 'hash : create wizard');
+check('hash : create wizard');
my %n = map { $_ => int rand 1000 } qw/foo bar baz qux/;
my %a = %n;
cast %a, $wiz;
-ok(check(), 'hash : cast');
+check('hash : cast');
my $b = $a{foo};
++$x[5] if MGf_COPY;
++$x[8] if VMG_UVAR;
-ok(check(), 'hash : assign element to');
+check('hash : assign element to');
my %b = %a;
-ok(check(), 'hash : assign to');
+check('hash : assign to');
$b = "X%{a}Y";
-ok(check(), 'hash : interpolate');
+check('hash : interpolate');
$b = \%a;
-ok(check(), 'hash : reference');
+check('hash : reference');
my @b = @a{qw/bar qux/};
$x[5] += 2 if MGf_COPY;
$x[8] += 2 if VMG_UVAR;
-ok(check(), 'hash : slice');
+check('hash : slice');
%a = (a => 1, d => 3);
++$x[3];
$x[5] += 2 if VMG_UVAR;
$x[9] += 2 if VMG_UVAR;
-ok(check(), 'hash : assign from list');
+check('hash : assign from list');
%a = map { $_ => 1 } qw/a b d/;
++$x[3];
$x[5] += 3 if VMG_UVAR;
$x[9] += 3 if VMG_UVAR;
-ok(check(), 'hash : assign from map');
+check('hash : assign from map');
$a{d} = 2;
++$x[5] if MGf_COPY;
++$x[9] if VMG_UVAR;
-ok(check(), 'hash : assign old element');
+check('hash : assign old element');
$a{c} = 3;
++$x[5] if MGf_COPY;
++$x[9] if VMG_UVAR;
-ok(check(), 'hash : assign new element');
+check('hash : assign new element');
$b = %a;
-ok(check(), 'hash : buckets');
+check('hash : buckets');
@b = keys %a;
-ok(check(), 'hash : keys');
+check('hash : keys');
@b = values %a;
-ok(check(), 'hash : values');
+check('hash : values');
while (my ($k, $v) = each %a) { }
-ok(check(), 'hash : each');
+check('hash : each');
{
my %b = %n;
cast %b, $wiz;
}
++$x[4];
-ok(check(), 'hash : scope end');
+check('hash : scope end');
undef %a;
++$x[3];
-ok(check(), 'hash : undef');
+check('hash : undef');
dispell %a, $wiz;
-ok(check(), 'hash : dispel');
+check('hash : dispel');
my @x = (0) x 12;
sub check {
- for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
- return 1;
+ is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 11]),
+ join(':', map { (defined) ? $_ : 'u' } @x[0 .. 11]),
+ $_[0];
}
my $i = -1;
store => sub { ++$c[9] },
'exists' => sub { ++$c[10] },
'delete' => sub { ++$c[11] };
-ok(check(), 'code : create wizard');
+check('code : create wizard');
my $x = 0;
my $n = sub { ++$x };
my $a = $n;
cast $a, $wiz;
-ok(check(), 'code : cast');
+check('code : cast');
my $b = $a;
++$x[0];
-ok(check(), 'code : assign to');
+check('code : assign to');
$b = "X${a}Y";
++$x[0];
-ok(check(), 'code : interpolate');
+check('code : interpolate');
$b = \$a;
-ok(check(), 'code : reference');
+check('code : reference');
$a = $n;
++$x[1];
-ok(check(), 'code : assign');
+check('code : assign');
$a->();
-ok(check(), 'code : call');
+check('code : call');
{
my $b = $n;
cast $b, $wiz;
}
++$x[4];
-ok(check(), 'code : scope end');
+check('code : scope end');
undef $a;
++$x[1];
-ok(check(), 'code : undef');
+check('code : undef');
dispell $a, $wiz;
-ok(check(), 'code : dispell');
+check('code : dispell');
my @x = (0) x 12;
sub check {
- for (0 .. 11) { return 0 unless $c[$_] == $x[$_]; }
- return 1;
+ is join(':', map { (defined) ? $_ : 'u' } @c[0 .. 11]),
+ join(':', map { (defined) ? $_ : 'u' } @x[0 .. 11]),
+ $_[0];
}
my $i = -1;
store => sub { ++$c[9] },
'exists' => sub { ++$c[10] },
'delete' => sub { ++$c[11] };
-ok(check(), 'glob : create wizard');
+check('glob : create wizard');
local *a = gensym();
cast *a, $wiz;
-ok(check(), 'glob : cast');
+check('glob : cast');
local *b = *a;
-ok(check(), 'glob : assign to');
+check('glob : assign to');
*a = gensym();
++$x[1];
-ok(check(), 'glob : assign');
+check('glob : assign');
{
local *b = gensym();
cast *b, $wiz;
}
-ok(check(), 'glob : scope end');
+check('glob : scope end');
undef *a;
-ok(check(), 'glob : undef');
+check('glob : undef');
dispell *a, $wiz;
-ok(check(), 'glob : dispell');
+check('glob : dispell');
projects / perl / modules / Variable-Magic.git / commitdiff