From: Vincent Pit Date: Sat, 30 Aug 2008 17:34:11 +0000 (+0200) Subject: No longer fork to test. IPC::Cmd is no longer required X-Git-Tag: v0.04~5 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=7ded1e91a0a0ddc3e709cda9573fe0e53a32e092;p=perl%2Fmodules%2Findirect.git No longer fork to test. IPC::Cmd is no longer required --- diff --git a/MANIFEST b/MANIFEST index 4222cbb..bf71375 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6,18 +6,13 @@ indirect.xs lib/indirect.pm samples/indirect.pl t/00-load.t -t/10-good-no.t -t/11-good-use.t -t/20-bad-no.t -t/21-bad-use.t -t/22-bad-fatal.t +t/10-good.t +t/20-bad.t +t/21-bad-fatal.t t/30-scope.t t/90-boilerplate.t t/91-pod.t t/92-pod-coverage.t t/95-portability-files.t t/99-kwalitee.t -t/data/bad.d -t/data/good.d -t/data/mixed.d META.yml Module meta-data (added by MakeMaker) diff --git a/Makefile.PL b/Makefile.PL index 2ded8f8..f1d1637 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -6,7 +6,6 @@ use ExtUtils::MakeMaker; my $BUILD_REQUIRES = { 'ExtUtils::MakeMaker' => 0, - 'IPC::Cmd' => 0, 'Test::More' => 0, }; diff --git a/lib/indirect.pm b/lib/indirect.pm index 7f29b3b..c355f6f 100644 --- a/lib/indirect.pm +++ b/lib/indirect.pm @@ -67,8 +67,6 @@ L 5.9.4. L (standard since perl 5.006). -Tests require L (standard since 5.9.5). - =head1 AUTHOR Vincent Pit, C<< >>, L. diff --git a/t/10-good-no.t b/t/10-good-no.t deleted file mode 100644 index 501b27d..0000000 --- a/t/10-good-no.t +++ /dev/null @@ -1,54 +0,0 @@ -#!perl - -use strict; -use warnings; - -my $total = 32; - -use Test::More; - -use IPC::Cmd qw/run/; - -(my $success, my $err_code, undef, undef, my $stderr) - = run command => [ - $^X, - map('-I' . $_, @INC), - $ENV{PERL5OPT} || '', - '-M-indirect', - '-c', - 't/data/good.d' - ]; - -plan skip_all => "Couldn't capture buffers" if $success and not defined $stderr; -plan tests => $total + 1; - -$stderr = join '', @{$stderr || []}; -unless ($success) { - diag $stderr; - diag "Failed to execute data file (error $err_code)"; - fail "Couldn't run test $_" for 1 .. $total + 1; - exit $total + 1; -} - -my %fail; -my $extra_fail = 0; - -while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) { - my ($m, $o) = ($1, $2); - my $id; - if ($m =~ /^(?:new|potato)(\d+)$/) { - $id = $1; - } elsif ($o =~ /^Hlagh(\d+)$/) { - $id = $1; - } else { - diag "$m $o"; - ++$extra_fail; - } - if ($id) { - fail("test $id shouldn't have failed"); - $fail{$id} = 1; - } -} - -pass("test $_ hasn't failed") for grep { !$fail{$_} } 1 .. $total; -is($extra_fail, 0, 'no extra fails'); diff --git a/t/10-good.t b/t/10-good.t new file mode 100644 index 0000000..14f96d2 --- /dev/null +++ b/t/10-good.t @@ -0,0 +1,122 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 32 * 2; + +my ($obj, $pkg, $cb, $x); +sub meh; + +{ + local $/ = "####\n"; + while () { + chomp; + { + use indirect; + local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) }; + eval "die qq{ok\\n}; $_"; + } + is($@, "ok\n", $_); + { + no indirect; + local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) }; + eval "die qq{ok\n}; $_"; + } + is($@, "ok\n", $_); + } +} + +__DATA__ +$obj = Hlagh->new; +#### +$obj = Hlagh->new(); +#### +$obj = Hlagh->new(1); +#### +$obj = Hlagh->new(q{foo}, bar => $obj); +#### +$obj = Hlagh -> new ; +#### +$obj = Hlagh -> new ( ) ; +#### +$obj = Hlagh -> new ( 1 ) ; +#### +$obj = Hlagh -> new ( 'foo' , bar => $obj ); +#### +$obj = Hlagh + -> + new ; +#### +$obj = Hlagh + + -> +new ( + ) ; +#### +$obj = Hlagh + -> new ( + 1 ) ; +#### +$obj = Hlagh -> + new ( "foo" + , bar + => $obj ); +#### +$obj = Hlagh->$cb; +#### +$obj = Hlagh->$cb(); +#### +$obj = Hlagh->$cb($pkg); +#### +$obj = Hlagh->$cb(sub { 'foo' }, bar => $obj); +#### +$obj = $pkg->new ; +#### +$obj = $pkg -> new ( ); +#### +$obj = $pkg + -> + new ( $pkg ); +#### +$obj = + $pkg +-> +new ( qr/foo/, + foo => qr/bar/ ); +#### +$obj + = +$pkg +-> +$cb +; +#### +$obj = $pkg -> ($cb) (); +#### +$obj = $pkg->$cb( $obj ); +#### +$obj = $pkg->$cb(qw/foo bar baz/); +#### +$obj = new { $x }; +#### +$obj = new + { + $x } + (); +#### +$obj = new { + $x } qq/foo/; +#### +$obj = new + { + $x + }(qw/bar baz/); +#### +meh $x; +#### +meh $x, 1 , 2; +#### +print STDOUT "bananananananana\n"; +#### +print $x "oh hai\n"; diff --git a/t/11-good-use.t b/t/11-good-use.t deleted file mode 100644 index 6f00254..0000000 --- a/t/11-good-use.t +++ /dev/null @@ -1,54 +0,0 @@ -#!perl - -use strict; -use warnings; - -my $total = 32; - -use Test::More; - -use IPC::Cmd qw/run/; - -(my $success, my $err_code, undef, undef, my $stderr) - = run command => [ - $^X, - map('-I' . $_, @INC), - $ENV{PERL5OPT} || '', - '-Mindirect', - '-c', - 't/data/good.d' - ]; - -plan skip_all => "Couldn't capture buffers" if $success and not defined $stderr; -plan tests => $total + 1; - -$stderr = join '', @{$stderr || []}; -unless ($success) { - diag $stderr; - diag "Failed to execute data file (error $err_code)"; - fail "Couldn't run test $_" for 1 .. $total + 1; - exit $total + 1; -} - -my %fail; -my $extra_fail = 0; - -while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) { - my ($m, $o) = ($1, $2); - my $id; - if ($m =~ /^(?:new|potato)(\d+)$/) { - $id = $1; - } elsif ($o =~ /^Hlagh(\d+)$/) { - $id = $1; - } else { - diag "$m $o"; - ++$extra_fail; - } - if ($id) { - fail("test $id shouldn't have failed"); - $fail{$id} = 1; - } -} - -pass("test $_ hasn't failed") for grep { !$fail{$_} } 1 .. $total; -is($extra_fail, 0, 'no extra fails'); diff --git a/t/20-bad-no.t b/t/20-bad-no.t deleted file mode 100644 index fbfceaf..0000000 --- a/t/20-bad-no.t +++ /dev/null @@ -1,54 +0,0 @@ -#!perl - -use strict; -use warnings; - -my $total = 28; - -use Test::More; - -use IPC::Cmd qw/run/; - -(my $success, my $err_code, undef, undef, my $stderr) - = run command => [ - $^X, - map('-I' . $_, @INC), - $ENV{PERL5OPT} || '', - '-M-indirect', - '-c', - 't/data/bad.d' - ]; - -plan skip_all => "Couldn't capture buffers" if $success and not defined $stderr; -plan tests => $total + 1; - -$stderr = join '', @{$stderr || []}; -unless ($success) { - diag $stderr; - diag "Failed to execute data file (error $err_code)"; - fail "Couldn't run test $_" for 1 .. $total + 1; - exit $total + 1; -} - -my %fail = map { $_ => 1 } 1 .. $total; -my $extra_fail = 0; - -while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) { - my ($m, $o) = ($1, $2); - my $id; - if ($m =~ /^(?:new|potato)(\d+)$/) { - $id = $1; - } elsif ($o =~ /^Hlagh(\d+)$/) { - $id = $1; - } else { - diag "$m $o"; - ++$extra_fail; - } - if ($id) { - ok($fail{$id}, "test $id failed as expected"); - delete $fail{$id}; - } -} - -fail("test $_ hasn't failed") for sort { $a <=> $b } keys %fail; -is($extra_fail, 0, 'no extra fails'); diff --git a/t/20-bad.t b/t/20-bad.t new file mode 100644 index 0000000..05efb50 --- /dev/null +++ b/t/20-bad.t @@ -0,0 +1,97 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 28 * 2; + +my ($obj, $pkg, $cb, $x); + +{ + local $/ = "####\n"; + while () { + chomp; + { + use indirect; + local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) }; + eval "die qq{ok\\n}; $_"; + } + is($@, "ok\n", $_); + { + no indirect; + local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) }; + eval "die qq{the code compiled but it shouldn't have\n}; $_"; + } + like($@, qr/^warn:Indirect\s+call\s+of\s+method\s+"(?:new|meh|HlaghHlagh)"\s+on\s+object\s+"(?:Hlagh|newnew|\$x|\$_)"/, $_); + } +} + +__DATA__ +$obj = new Hlagh; +#### +$obj = new Hlagh(); +#### +$obj = new Hlagh(1); +#### +$obj = new Hlagh(1, 2); +#### +$obj = new Hlagh ; +#### +$obj = new Hlagh ( ) ; +#### +$obj = new Hlagh ( 1 ) ; +#### +$obj = new Hlagh ( 1 , 2 ) ; +#### +$obj = new + Hlagh + ; +#### +$obj = new + Hlagh ( + ) ; +#### +$obj = + new + Hlagh ( 1 + ) ; +#### +$obj = +new +Hlagh + ( 1 , + 2 ) ; +#### +$obj = new $x; +#### +$obj = new $x(); +#### +$obj = new $x('foo'); +#### +$obj = new $x qq{foo}, 1; +#### +$obj = new $x qr{foo\s+bar}, 1 .. 1; +#### +$obj = new $x(qw/bar baz/); +#### +$obj = new + $_; +#### +$obj = new + $_ ( ); +#### +$obj = new $_ qr/foo/ ; +#### +$obj = new $_ qq(bar baz); +#### +meh $x; +#### +meh $x, 1, 2; +#### +$obj = HlaghHlagh Hlagh; +#### +$obj = HlaghHlagh Hlagh; # HlaghHlagh Hlagh +#### +$obj = new newnew; +#### +$obj = new newnew; # new newnew diff --git a/t/21-bad-fatal.t b/t/21-bad-fatal.t new file mode 100644 index 0000000..6b7b61c --- /dev/null +++ b/t/21-bad-fatal.t @@ -0,0 +1,17 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 1; + +{ + local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) }; + eval < [ - $^X, - map('-I' . $_, @INC), - $ENV{PERL5OPT} || '', - '-Mindirect', - '-c', - 't/data/bad.d' - ]; - -plan skip_all => "Couldn't capture buffers" if $success and not defined $stderr; -plan tests => $total + 1; - -$stderr = join '', @{$stderr || []}; -unless ($success) { - diag $stderr; - diag "Failed to execute data file (error $err_code)"; - fail "Couldn't run test $_" for 1 .. $total + 1; - exit $total + 1; -} - -my %fail; -my $extra_fail = 0; - -while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) { - my ($m, $o) = ($1, $2); - my $id; - if ($m =~ /^(?:new|potato)(\d+)$/) { - $id = $1; - } elsif ($o =~ /^Hlagh(\d+)$/) { - $id = $1; - } else { - diag "$m $o"; - ++$extra_fail; - } - if ($id) { - fail("test $id shouldn't have failed"); - $fail{$id} = 1; - } -} - -pass("test $_ hasn't failed") for grep { !$fail{$_} } 1 .. $total; -is($extra_fail, 0, 'no extra fails'); diff --git a/t/22-bad-fatal.t b/t/22-bad-fatal.t deleted file mode 100644 index 111524d..0000000 --- a/t/22-bad-fatal.t +++ /dev/null @@ -1,24 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; - -use IPC::Cmd qw/run/; - -(my $success, my $err_code, undef, undef, my $stderr) - = run command => [ - $^X, - map('-I' . $_, @INC), - $ENV{PERL5OPT} || '', - '-M-indirect=:fatal', - '-c', - 't/data/bad.d' - ]; - -plan skip_all => "Couldn't capture buffers" if $success and not defined $stderr; -plan tests => 1; - -$stderr = join '', @{$stderr || []}; -ok(!$success && $err_code && $stderr =~ /^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"Hlagh1"/mg, 'croak when :fatal is specified'); diff --git a/t/30-scope.t b/t/30-scope.t index e4d667c..f2a785f 100644 --- a/t/30-scope.t +++ b/t/30-scope.t @@ -1,58 +1,63 @@ -#!perl +#!perl -T use strict; use warnings; -my $total = 8; +my $tests; +BEGIN { $tests = 8 } -use Test::More; +use Test::More tests => $tests + 1; -use IPC::Cmd qw/run/; +my %wrong = map { $_ => 1 } 2, 3, 5, 7; -(my $success, my $err_code, undef, undef, my $stderr) - = run command => [ - $^X, - map('-I' . $_, @INC), - $ENV{PERL5OPT} || '', - '-c', - 't/data/mixed.d' - ]; - -plan skip_all => "Couldn't capture buffers" if $success and not defined $stderr; -plan tests => $total + 1; - -$stderr = join '', @{$stderr || []}; -unless ($success) { - diag $stderr; - diag "Failed to execute data file (error $err_code)"; - fail "Couldn't run test $_" for 1 .. $total + 1; - exit $total + 1; -} - -my %fail = map { $_ => 1 } 2, 3, 5, 7; -my %failed; -my $extra_fail = 0; - -while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) { - my ($m, $o) = ($1, $2); - my $id; - if ($o =~ /^P(\d+)$/) { - $id = $1; - } else { - diag "$m $o"; - ++$extra_fail; +{ + my $code = do { local $/; }; + my @warns; + { + local $SIG{__WARN__} = sub { push @warns, join '', 'warn:', @_ }; + eval "die qq{ok\\n}; $code"; } - if ($id) { - if (exists $fail{$id}) { - pass("test $id failed as expected"); - delete $fail{$id}; - $failed{$id} = 1; + my $left = 0; + my %res = map { + if (/"P(\d+)"/) { + $1 => $_ } else { - fail("test $id shouldn't have failed"); + ++$left; () + } + } @warns; + for (1 .. $tests) { + my $w = $res{$_}; + if ($wrong{$_}) { + like($w, qr/^warn:Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"P$_"/, "$_ should warn"); + } else { + is($w, undef, "$_ shouldn't warn"); } } + is($left, 0, 'nothing left'); } -pass("test $_ hasn't failed") for grep { !$failed{$_} } 1 .. $total; -fail("test $_ should have failed") for sort { $a <=> $b } keys %fail; -is($extra_fail, 0, 'no extra fails'); +__DATA__ +my $a = new P1; + +{ + no indirect; + my $b = new P2; + { + my $c = new P3; + } + { + use indirect; + my $d = new P4; + } + my $e = new P5; +} + +my $f = new P6; + +no indirect; + +my $g = new P7; + +use indirect; + +my $h = new P8; diff --git a/t/data/bad.d b/t/data/bad.d deleted file mode 100644 index feb9d7f..0000000 --- a/t/data/bad.d +++ /dev/null @@ -1,57 +0,0 @@ -#!perl - -use strict; -use warnings; - -my $obj; -my $pkg; -my $cb; - -$obj = new Hlagh1; -$obj = new Hlagh2(); -$obj = new Hlagh3(1); -$obj = new Hlagh4(1, 2); - -$obj = new Hlagh5 ; -$obj = new Hlagh6 ( ) ; -$obj = new Hlagh7 ( 1 ) ; -$obj = new Hlagh8 ( 1 , 2 ) ; - -$obj = new - Hlagh9 - ; -$obj = new - Hlagh10 ( - ) ; -$obj = - new - Hlagh11 ( 1 - ) ; -$obj = -new -Hlagh12 - ( 1 , - 2 ) ; - -my $x; -$obj = new13 $x; -$obj = new14 $x(); -$obj = new15 $x('foo'); -$obj = new16 $x qq{foo}, 1; -$obj = new17 $x qr{foo\s+bar}, 1 .. 1; -$obj = new18 $x(qw/bar baz/); - -$obj = new19 - $_; -$obj = new20 - $_ ( ); -$obj = new21 $_ qr/foo/ ; -$obj = new22 $_ qq(bar baz); - -potato23 $x; -potato24 $x, 1, 2; - -$obj = Hlagh25Hlagh25 Hlagh25; -$obj = Hlagh26Hlagh26 Hlagh26; # Hlagh26Hlagh26 Hlagh26 -$obj = new27 new27new27; -$obj = new28 new28new28; # new28 new28new28 diff --git a/t/data/good.d b/t/data/good.d deleted file mode 100644 index 16124c9..0000000 --- a/t/data/good.d +++ /dev/null @@ -1,83 +0,0 @@ -#!perl - -use strict; -use warnings; - -my $obj; -my $pkg; -my $cb; - -$obj = Hlagh1->new; -$obj = Hlagh2->new(); -$obj = Hlagh3->new(1); -$obj = Hlagh4->new(q{foo}, bar => $obj); - -$obj = Hlagh5 -> new ; -$obj = Hlagh6 -> new ( ) ; -$obj = Hlagh7 -> new ( 1 ) ; -$obj = Hlagh8 -> new ( 'foo' , bar => $obj ); - -$obj = Hlagh9 - -> - new ; -$obj = Hlagh10 - - -> -new ( - ) ; -$obj = Hlagh11 - -> new ( - 1 ) ; -$obj = Hlagh12 -> - new ( "foo" - , bar - => $obj ); - -$obj = Hlagh13->$cb; -$obj = Hlagh14->$cb(); -$obj = Hlagh15->$cb($pkg); -$obj = Hlagh16->$cb(sub { 'foo' }, bar => $obj); - -$obj = $pkg->new17 ; -$obj = $pkg -> new18 ( ); -$obj = $pkg - -> - new19 ( $pkg ); -$obj = - $pkg --> -new20 ( qr/foo/, - foo => qr/bar/ ); - -$obj - = -$pkg --> -$cb -; -$obj = $pkg -> ($cb) (); -$obj = $pkg->$cb( $obj ); -$obj = $pkg->$cb(qw/foo bar baz/); - -my $x; - -$obj = new25 { $x }; -$obj = new26 - { - $x } - (); -$obj = new27 { - $x } qq/foo/; -$obj = new28 - { - $x - }(qw/bar baz/); - -sub potato29; -sub potato30; - -potato29 $x; -potato30 $x, 1 , 2; - -print STDOUT "bananananananana\n"; -print $x "oh hai\n"; diff --git a/t/data/mixed.d b/t/data/mixed.d deleted file mode 100644 index 3440aa8..0000000 --- a/t/data/mixed.d +++ /dev/null @@ -1,29 +0,0 @@ -#!perl - -use strict; -use warnings; - -my $a = new P1; - -{ - no indirect; - my $b = new P2; - { - my $c = new P3; - } - { - use indirect; - my $d = new P4; - } - my $e = new P5; -} - -my $f = new P6; - -no indirect; - -my $g = new P7; - -use indirect; - -my $h = new P8;