From: Vincent Pit Date: Sun, 29 Jun 2008 16:24:46 +0000 (+0200) Subject: Importing Variable-Magic-0.13.tar.gz X-Git-Tag: v0.13^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=a86e3e47a167afadf7de1231d6401a1139330ad0 Importing Variable-Magic-0.13.tar.gz --- diff --git a/Changes b/Changes index f725b88..c77f730 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,13 @@ 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. diff --git a/META.yml b/META.yml index 00e65e7..8362d35 100644 --- a/META.yml +++ b/META.yml @@ -1,17 +1,20 @@ --- #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 -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 diff --git a/Makefile.PL b/Makefile.PL index ebe7a50..a8d679e 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -4,14 +4,14 @@ use strict; 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; @@ -21,23 +21,39 @@ if (defined $pl && length $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 ', - LICENSE => 'perl', - VERSION_FROM => 'lib/Variable/Magic.pm', - ABSTRACT_FROM => 'lib/Variable/Magic.pm', - PL_FILES => {}, + NAME => 'Variable::Magic', + AUTHOR => 'Vincent Pit ', + 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' }, ); diff --git a/README b/README index 3538875..4acb5fe 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME 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/; @@ -282,9 +282,10 @@ SEE ALSO perltie and overload for other ways of enhancing objects. AUTHOR - Vincent Pit, "" + Vincent Pit, "", . - 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 @@ -298,6 +299,9 @@ SUPPORT perldoc Variable::Magic + Tests code coverage report is available at + . + COPYRIGHT & LICENSE Copyright 2007-2008 Vincent Pit, all rights reserved. diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index dd41d05..fb2e252 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -13,13 +13,13 @@ Variable::Magic - Associate user-defined magic to variables from Perl. =head1 VERSION -Version 0.12 +Version 0.13 =cut our $VERSION; BEGIN { - $VERSION = '0.12'; + $VERSION = '0.13'; } =head1 SYNOPSIS @@ -329,17 +329,13 @@ L and L for other ways of enhancing objects. =head1 AUTHOR -Vincent Pit, C<< >> +Vincent Pit, C<< >>, L. -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, or through the web interface at -L. -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, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT @@ -347,6 +343,8 @@ You can find documentation for this module with the perldoc command. perldoc Variable::Magic +Tests code coverage report is available at L. + =head1 COPYRIGHT & LICENSE Copyright 2007-2008 Vincent Pit, all rights reserved. diff --git a/t/00-load.t b/t/00-load.t index e70be36..0abe93c 100644 --- a/t/00-load.t +++ b/t/00-load.t @@ -3,10 +3,14 @@ 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" ); diff --git a/t/10-simple.t b/t/10-simple.t index 99136bd..adcbf34 100644 --- a/t/10-simple.t +++ b/t/10-simple.t @@ -3,38 +3,62 @@ 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; { @@ -44,5 +68,9 @@ $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'); diff --git a/t/11-multiple.t b/t/11-multiple.t index fc68cf2..44da791 100644 --- a/t/11-multiple.t +++ b/t/11-multiple.t @@ -3,7 +3,7 @@ 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/; @@ -31,8 +31,8 @@ multi sub { $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; @@ -42,58 +42,60 @@ multi sub { 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); @@ -103,31 +105,51 @@ SKIP: { 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'); } diff --git a/t/12-sig.t b/t/12-sig.t index 6564d36..fa1a34b 100644 --- a/t/12-sig.t +++ b/t/12-sig.t @@ -13,16 +13,16 @@ my ($a, $b, $c, $d) = 1 .. 4; { 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 }; diff --git a/t/13-data.t b/t/13-data.t index 1e8b9eb..313e1df 100644 --- a/t/13-data.t +++ b/t/13-data.t @@ -3,54 +3,81 @@ 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'); diff --git a/t/14-callbacks.t b/t/14-callbacks.t index a34549a..dffb6d9 100644 --- a/t/14-callbacks.t +++ b/t/14-callbacks.t @@ -8,21 +8,21 @@ use Test::More tests => 7; 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'); diff --git a/t/15-self.t b/t/15-self.t index 6f6d9a4..cff8429 100644 --- a/t/15-self.t +++ b/t/15-self.t @@ -17,37 +17,37 @@ my $c = 0; }; 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'); diff --git a/t/16-huf.t b/t/16-huf.t index 7d28277..6a2f750 100644 --- a/t/16-huf.t +++ b/t/16-huf.t @@ -11,41 +11,42 @@ if (!VMG_UVAR) { 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'); diff --git a/t/20-get.t b/t/20-get.t index b79edc8..60826a1 100644 --- a/t/20-get.t +++ b/t/20-get.t @@ -9,18 +9,18 @@ use Variable::Magic qw/wizard cast/; 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'); diff --git a/t/21-set.t b/t/21-set.t index f731c0d..095b482 100644 --- a/t/21-set.t +++ b/t/21-set.t @@ -9,21 +9,21 @@ use Variable::Magic qw/wizard cast/; 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'); diff --git a/t/22-len.t b/t/22-len.t index c3a9566..0a6dd59 100644 --- a/t/22-len.t +++ b/t/22-len.t @@ -10,18 +10,18 @@ use Variable::Magic qw/wizard cast/; 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'); diff --git a/t/23-clear.t b/t/23-clear.t index 35a49dd..ec8f9aa 100644 --- a/t/23-clear.t +++ b/t/23-clear.t @@ -9,22 +9,22 @@ use Variable::Magic qw/wizard cast/; 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'); diff --git a/t/24-free.t b/t/24-free.t index 5a90198..89e2c06 100644 --- a/t/24-free.t +++ b/t/24-free.t @@ -9,7 +9,7 @@ use Variable::Magic qw/wizard cast/; 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; @@ -17,10 +17,10 @@ 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()'); diff --git a/t/25-copy.t b/t/25-copy.t index 3a033a3..83e604a 100644 --- a/t/25-copy.t +++ b/t/25-copy.t @@ -15,7 +15,7 @@ if (MGf_COPY) { 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"; @@ -25,22 +25,22 @@ SKIP: { @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: { @@ -52,34 +52,34 @@ 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'); } diff --git a/t/27-local.t b/t/27-local.t index 9ecddd6..27dfd8b 100644 --- a/t/27-local.t +++ b/t/27-local.t @@ -15,15 +15,15 @@ if (MGf_LOCAL) { 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'); diff --git a/t/28-uvar.t b/t/28-uvar.t index 364c7cd..7fa30b1 100644 --- a/t/28-uvar.t +++ b/t/28-uvar.t @@ -17,53 +17,54 @@ my @c = (0) x 4; 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 }; @@ -74,12 +75,12 @@ eval { 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'); diff --git a/t/30-scalar.t b/t/30-scalar.t index bdad8ed..eb1a412 100644 --- a/t/30-scalar.t +++ b/t/30-scalar.t @@ -11,8 +11,9 @@ my @c = (0) x 12; 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; @@ -28,55 +29,55 @@ my $wiz = wizard get => sub { ++$c[0] }, 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'); diff --git a/t/31-array.t b/t/31-array.t index 2fee830..9f49f2e 100644 --- a/t/31-array.t +++ b/t/31-array.t @@ -11,8 +11,9 @@ my @c = (0) x 12; 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] }, @@ -27,84 +28,84 @@ 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'); diff --git a/t/32-hash.t b/t/32-hash.t index 572f5e6..8639053 100644 --- a/t/32-hash.t +++ b/t/32-hash.t @@ -11,8 +11,9 @@ my @c = (0) x 12; 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] }, @@ -27,77 +28,77 @@ 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'); diff --git a/t/33-code.t b/t/33-code.t index 7b63399..40c32a4 100644 --- a/t/33-code.t +++ b/t/33-code.t @@ -11,8 +11,9 @@ my @c = (0) x 12; 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; @@ -28,43 +29,43 @@ my $wiz = wizard get => sub { ++$c[0] }, 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'); diff --git a/t/34-glob.t b/t/34-glob.t index 58bcd72..b401b4c 100644 --- a/t/34-glob.t +++ b/t/34-glob.t @@ -18,8 +18,9 @@ my @c = (0) x 12; 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; @@ -35,28 +36,28 @@ my $wiz = wizard get => sub { ++$c[0] }, 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');