In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/a0c9a42addb0f12cd063fe87f58c2fb2dbe069fb?hp=16acebfd4bd4723d04bc78197c2f63138974bfc8>
- Log ----------------------------------------------------------------- commit a0c9a42addb0f12cd063fe87f58c2fb2dbe069fb Author: Nicholas Clark <[email protected]> Date: Sun Mar 13 14:08:36 2011 +0000 Convert t/op/do.t to test.pl, strict and warnings. Also use tempfile(), rather than names derived from the process ID. ----------------------------------------------------------------------- Summary of changes: t/op/do.t | 172 +++++++++++++++++++++++++++++++------------------------------ 1 files changed, 88 insertions(+), 84 deletions(-) diff --git a/t/op/do.t b/t/op/do.t index e47441a..787d632 100644 --- a/t/op/do.t +++ b/t/op/do.t @@ -1,196 +1,200 @@ -#!./perl +#!./perl -w + +require './test.pl'; +use strict; +no warnings 'void'; sub foo1 { - ok($_[0]); + ok($_[0], 'in foo1'); 'value'; } sub foo2 { shift; - ok($_[0]); - $x = 'value'; + ok($_[0], 'in foo2'); + my $x = 'value'; $x; } -my $test = 1; -sub ok { - my($ok, $name) = @_; - - # You have to do it this way or VMS will get confused. - printf "%s %d%s\n", $ok ? "ok" : "not ok", - $test, - defined $name ? " - $name" : ''; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - - $test++; - return $ok; -} - -print "1..50\n"; - -# Test do &sub and proper @_ handling. +my $result; $_[0] = 0; { no warnings 'deprecated'; $result = do foo1(1); } -ok( $result eq 'value', ":$result: eq :value:" ); -ok( $_[0] == 0 ); +is($result, 'value', 'do &sub and proper @_ handling'); +cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); $_[0] = 0; { no warnings 'deprecated'; $result = do foo2(0,1,0); } -ok( $result eq 'value', ":$result: eq :value:" ); -ok( $_[0] == 0 ); +is($result, 'value', 'do &sub and proper @_ handling'); +cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); -$result = do{ ok 1; 'value';}; -ok( $result eq 'value', ":$result: eq :value:" ); +my $called; +$result = do{ ++$called; 'value';}; +is($called, 1, 'do block called'); +is($result, 'value', 'do block returns correct value'); +my @blathered; sub blather { - ok 1 foreach @_; + push @blathered, $_ foreach @_; } { no warnings 'deprecated'; do blather("ayep","sho nuff"); + is("@blathered", "ayep sho nuff", 'blathered called with list'); } -@x = ("jeepers", "okydoke"); -@y = ("uhhuh", "yeppers"); +@blathered = (); + +my @x = ("jeepers", "okydoke"); +my @y = ("uhhuh", "yeppers"); { no warnings 'deprecated'; do blather(@x,"noofie",@y); + is("@blathered", "@x noofie @y", 'blathered called with arrays too'); } unshift @INC, '.'; -if (open(DO, ">$$.16")) { - print DO "ok(1, 'do in scalar context') if defined wantarray && not wantarray\n"; - close DO or die "Could not close: $!"; +my $file16 = tempfile(); +if (open my $do, '>', $file16) { + print $do "isnt(wantarray, undef, 'do in scalar context');\n"; + print $do "cmp_ok(wantarray, '==', 0, 'do in scalar context');\n"; + close $do or die "Could not close: $!"; } -my $a = do "$$.16"; die $@ if $@; +my $a = do $file16; die $@ if $@; -if (open(DO, ">$$.17")) { - print DO "ok(1, 'do in list context') if defined wantarray && wantarray\n"; - close DO or die "Could not close: $!"; +my $file17 = tempfile(); +if (open my $do, '>', $file17) { + print $do "isnt(wantarray, undef, 'do in list context');\n"; + print $do "cmp_ok(wantarray, '!=', 0, 'do in list context');\n"; + close $do or die "Could not close: $!"; } -my @a = do "$$.17"; die $@ if $@; +my @a = do $file17; die $@ if $@; -if (open(DO, ">$$.18")) { - print DO "ok(1, 'do in void context') if not defined wantarray\n"; - close DO or die "Could not close: $!"; +my $file18 = tempfile(); +if (open my $do, '>', $file18) { + print $do "is(wantarray, undef, 'do in void context');\n"; + close $do or die "Could not close: $!"; } -do "$$.18"; die $@ if $@; +do $file18; die $@ if $@; # bug ID 20010920.007 eval qq{ do qq(a file that does not exist); }; -ok( !$@, "do on a non-existing file, first try" ); +is($@, '', "do on a non-existing file, first try"); eval qq{ do uc qq(a file that does not exist); }; -ok( !$@, "do on a non-existing file, second try" ); +is($@, '', "do on a non-existing file, second try"); # 6 must be interpreted as a file name here -ok( (!defined do 6) && $!, "'do 6' : $!" ); +$! = 0; +my $do6 = do 6; +my $errno = $1; +is($do6, undef, 'do 6 must be interpreted as a filename'); +isnt($!, 0, 'and should set $!'); # [perl #19545] -push @t, ($u = (do {} . "This should be pushed.")); -ok( $#t == 0, "empty do result value" ); +my ($u, @t); +{ + no warnings 'uninitialized'; + push @t, ($u = (do {} . "This should be pushed.")); +} +is($#t, 0, "empty do result value" ); -$zok = ''; -$owww = do { 1 if $zok }; -ok( $owww eq '', 'last is unless' ); +my $zok = ''; +my $owww = do { 1 if $zok }; +is($owww, '', 'last is unless'); $owww = do { 2 unless not $zok }; -ok( $owww == 1, 'last is if not' ); +is($owww, 1, 'last is if not'); $zok = 'swish'; $owww = do { 3 unless $zok }; -ok( $owww eq 'swish', 'last is unless' ); +is($owww, 'swish', 'last is unless'); $owww = do { 4 if not $zok }; -ok( $owww eq '', 'last is if not' ); +is($owww, '', 'last is if not'); # [perl #38809] @a = (7); -$x = sub { do { return do { @a } }; 2 }->(); -ok(defined $x && $x == 1, 'return do { } receives caller scalar context'); +my $x = sub { do { return do { @a } }; 2 }->(); +is($x, 1, 'return do { } receives caller scalar context'); @x = sub { do { return do { @a } }; 2 }->(); -ok("@x" eq "7", 'return do { } receives caller list context'); +is("@x", "7", 'return do { } receives caller list context'); @a = (7, 8); $x = sub { do { return do { 1; @a } }; 3 }->(); -ok(defined $x && $x == 2, 'return do { ; } receives caller scalar context'); +is($x, 2, 'return do { ; } receives caller scalar context'); @x = sub { do { return do { 1; @a } }; 3 }->(); -ok("@x" eq "7 8", 'return do { ; } receives caller list context'); +is("@x", "7 8", 'return do { ; } receives caller list context'); -@b = (11 .. 15); +my @b = (11 .. 15); $x = sub { do { return do { 1; @a, @b } }; 3 }->(); -ok(defined $x && $x == 5, 'return do { ; , } receives caller scalar context'); +is($x, 5, 'return do { ; , } receives caller scalar context'); @x = sub { do { return do { 1; @a, @b } }; 3 }->(); -ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context'); +is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context'); $x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); -ok(defined $x && $x == 5, 'return do { ; }, do { ; } receives caller scalar context'); +is($x, 5, 'return do { ; }, do { ; } receives caller scalar context'); @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); -ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context'); +is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context'); @a = (7, 8, 9); $x = sub { do { do { 1; return @a } }; 4 }->(); -ok(defined $x && $x == 3, 'do { return } receives caller scalar context'); +is($x, 3, 'do { return } receives caller scalar context'); @x = sub { do { do { 1; return @a } }; 4 }->(); -ok("@x" eq "7 8 9", 'do { return } receives caller list context'); +is("@x", "7 8 9", 'do { return } receives caller list context'); @a = (7, 8, 9, 10); $x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); -ok(defined $x && $x == 4, 'return do { do { ; } } receives caller scalar context'); +is($x, 4, 'return do { do { ; } } receives caller scalar context'); @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); -ok("@x" eq "7 8 9 10", 'return do { do { ; } } receives caller list context'); +is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context'); # Do blocks created by constant folding # [perl #68108] $x = sub { if (1) { 20 } }->(); -ok($x == 20, 'if (1) { $x } receives caller scalar context'); +is($x, 20, 'if (1) { $x } receives caller scalar context'); @a = (21 .. 23); $x = sub { if (1) { @a } }->(); -ok($x == 3, 'if (1) { @a } receives caller scalar context'); +is($x, 3, 'if (1) { @a } receives caller scalar context'); @x = sub { if (1) { @a } }->(); -ok("@x" eq "21 22 23", 'if (1) { @a } receives caller list context'); +is("@x", "21 22 23", 'if (1) { @a } receives caller list context'); $x = sub { if (1) { 0; 20 } }->(); -ok($x == 20, 'if (1) { ...; $x } receives caller scalar context'); +is($x, 20, 'if (1) { ...; $x } receives caller scalar context'); @a = (24 .. 27); $x = sub { if (1) { 0; @a } }->(); -ok($x == 4, 'if (1) { ...; @a } receives caller scalar context'); +is($x, 4, 'if (1) { ...; @a } receives caller scalar context'); @x = sub { if (1) { 0; @a } }->(); -ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); +is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); $x = sub { if (1) { 0; 20 } else{} }->(); -ok($x == 20, 'if (1) { ...; $x } else{} receives caller scalar context'); +is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context'); @a = (24 .. 27); $x = sub { if (1) { 0; @a } else{} }->(); -ok($x == 4, 'if (1) { ...; @a } else{} receives caller scalar context'); +is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context'); @x = sub { if (1) { 0; @a } else{} }->(); -ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context'); +is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context'); $x = sub { if (0){} else { 0; 20 } }->(); -ok($x == 20, 'if (0){} else { ...; $x } receives caller scalar context'); +is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context'); @a = (24 .. 27); $x = sub { if (0){} else { 0; @a } }->(); -ok($x == 4, 'if (0){} else { ...; @a } receives caller scalar context'); +is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context'); @x = sub { if (0){} else { 0; @a } }->(); -ok("@x" eq "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context'); - +is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context'); -END { - 1 while unlink("$$.16", "$$.17", "$$.18"); -} +done_testing(); -- Perl5 Master Repository
