diff options
Diffstat (limited to 'cpan/autodie/t')
59 files changed, 2555 insertions, 0 deletions
diff --git a/cpan/autodie/t/00-load.t b/cpan/autodie/t/00-load.t new file mode 100755 index 0000000000..d07fcaefbe --- /dev/null +++ b/cpan/autodie/t/00-load.t @@ -0,0 +1,9 @@ +#!perl -T + +use Test::More tests => 1; + +BEGIN { + use_ok( 'Fatal' ); +} + +# diag( "Testing Fatal $Fatal::VERSION, Perl $], $^X" ); diff --git a/cpan/autodie/t/Fatal.t b/cpan/autodie/t/Fatal.t new file mode 100755 index 0000000000..a291837d13 --- /dev/null +++ b/cpan/autodie/t/Fatal.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl -w +use strict; + +use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY"; + +use Test::More tests => 17; + +use Fatal qw(open close :void opendir); + +eval { open FOO, "<".NO_SUCH_FILE }; # Two arg open +like($@, qr/^Can't open/, q{Package Fatal::open}); +is(ref $@, "", "Regular fatal throws a string"); + +my $foo = 'FOO'; +for ('$foo', "'$foo'", "*$foo", "\\*$foo") { + eval qq{ open $_, '<$0' }; + + is($@,"", "Open using filehandle named - $_"); + + like(scalar(<$foo>), qr{^#!.*/perl}, "File contents using - $_"); + eval qq{ close FOO }; + + is($@,"", "Close filehandle using - $_"); +} + +eval { opendir FOO, NO_SUCH_FILE }; +like($@, qr{^Can't open}, "Package :void Fatal::opendir"); + +eval { my $a = opendir FOO, NO_SUCH_FILE }; +is($@, "", "Package :void Fatal::opendir in scalar context"); + +eval { Fatal->import(qw(print)) }; +like( + $@, qr{Cannot make the non-overridable builtin print fatal}, + "Can't override print" +); diff --git a/cpan/autodie/t/autodie.t b/cpan/autodie/t/autodie.t new file mode 100755 index 0000000000..c528a160a4 --- /dev/null +++ b/cpan/autodie/t/autodie.t @@ -0,0 +1,103 @@ +#!/usr/bin/perl -w +use strict; + +use constant NO_SUCH_FILE => 'this_file_had_so_better_not_be_here'; + +use Test::More tests => 19; + +{ + + use autodie qw(open); + + eval { open(my $fh, '<', NO_SUCH_FILE); }; + like($@,qr{Can't open},"autodie qw(open) in lexical scope"); + + no autodie qw(open); + + eval { open(my $fh, '<', NO_SUCH_FILE); }; + is($@,"","no autodie qw(open) in lexical scope"); + + use autodie qw(open); + eval { open(my $fh, '<', NO_SUCH_FILE); }; + like($@,qr{Can't open},"autodie qw(open) in lexical scope 2"); + + no autodie; # Should turn off all autodying subs + eval { open(my $fh, '<', NO_SUCH_FILE); }; + is($@,"","no autodie in lexical scope 2"); + + # Turn our pragma on one last time, so we can verify that + # falling out of this block reverts it back to previous + # behaviour. + use autodie qw(open); + eval { open(my $fh, '<', NO_SUCH_FILE); }; + like($@,qr{Can't open},"autodie qw(open) in lexical scope 3"); + +} + +eval { open(my $fh, '<', NO_SUCH_FILE); }; +is($@,"","autodie open outside of lexical scope"); + +eval { + use autodie; # Should turn on everything + open(my $fh, '<', NO_SUCH_FILE); +}; + +like($@, qr{Can't open}, "vanilla use autodie turns on everything."); + +eval { open(my $fh, '<', NO_SUCH_FILE); }; +is($@,"","vanilla autodie cleans up"); + +{ + use autodie qw(:io); + + eval { open(my $fh, '<', NO_SUCH_FILE); }; + like($@,qr{Can't open},"autodie q(:io) makes autodying open"); + + no autodie qw(:io); + + eval { open(my $fh, '<', NO_SUCH_FILE); }; + is($@,"", "no autodie qw(:io) disabled autodying open"); +} + +{ + package Testing_autodie; + + use Test::More; + + use constant NO_SUCH_FILE => ::NO_SUCH_FILE(); + + use Fatal qw(open); + + eval { open(my $fh, '<', NO_SUCH_FILE); }; + + like($@, qr{Can't open}, "Package fatal working"); + is(ref $@,"","Old Fatal throws strings"); + + { + use autodie qw(open); + + ok(1,"use autodie allowed with Fatal"); + + eval { open(my $fh, '<', NO_SUCH_FILE); }; + like($@, qr{Can't open}, "autodie and Fatal works"); + isa_ok($@, "autodie::exception"); # autodie throws real exceptions + + } + + eval { open(my $fh, '<', NO_SUCH_FILE); }; + + like($@, qr{Can't open}, "Package fatal working after autodie"); + is(ref $@,"","Old Fatal throws strings after autodie"); + + eval " no autodie qw(open); "; + + ok($@,"no autodie on Fataled sub an error."); + + eval " + no autodie qw(close); + use Fatal 'close'; + "; + + like($@, qr{not allowed}, "Using fatal after autodie is an error."); +} + diff --git a/cpan/autodie/t/autodie_test_module.pm b/cpan/autodie/t/autodie_test_module.pm new file mode 100644 index 0000000000..e8e824c522 --- /dev/null +++ b/cpan/autodie/t/autodie_test_module.pm @@ -0,0 +1,18 @@ +package main; +use strict; +use warnings; + +# Calls open, while still in the main package. This shouldn't +# be autodying. +sub leak_test { + return open(my $fh, '<', $_[0]); +} + +package autodie_test_module; + +# This should be calling CORE::open +sub your_open { + return open(my $fh, '<', $_[0]); +} + +1; diff --git a/cpan/autodie/t/backcompat.t b/cpan/autodie/t/backcompat.t new file mode 100755 index 0000000000..acb81245b8 --- /dev/null +++ b/cpan/autodie/t/backcompat.t @@ -0,0 +1,14 @@ +#!/usr/bin/perl -w +use strict; +use Fatal qw(open); +use Test::More tests => 2; +use constant NO_SUCH_FILE => "xyzzy_this_file_is_not_here"; + +eval { + open(my $fh, '<', NO_SUCH_FILE); +}; + +my $old_msg = qr{Can't open\(GLOB\(0x[0-9a-f]+\), <, xyzzy_this_file_is_not_here\): .* at \(eval \d+\)(?:\[.*?\])? line \d+\s+main::__ANON__\('GLOB\(0x[0-9a-f]+\)',\s*'<',\s*'xyzzy_this_file_is_not_here'\) called at \S+ line \d+\s+eval \Q{...}\E called at \S+ line \d+}; + +like($@,$old_msg,"Backwards compat ugly messages"); +is(ref($@),"", "Exception is a string, not an object"); diff --git a/cpan/autodie/t/basic_exceptions.t b/cpan/autodie/t/basic_exceptions.t new file mode 100755 index 0000000000..c732dd587d --- /dev/null +++ b/cpan/autodie/t/basic_exceptions.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w +use strict; + +use Test::More tests => 19; + +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; + +my $line; + +eval { + use autodie ':io'; + $line = __LINE__; open(my $fh, '<', NO_SUCH_FILE); +}; + +like($@, qr/Can't open '\w+' for reading: /, "Prety printed open msg"); +like($@, qr{\Q$0\E}, "Our file mention in error message"); + +like($@, qr{for reading: '.+'}, "Error should be in single-quotes"); +like($@->errno,qr/./, "Errno should not be empty"); + +like($@, qr{\n$}, "Errors should end with a newline"); +is($@->file, $0, "Correct file"); +is($@->function, 'CORE::open', "Correct dying sub"); +is($@->package, __PACKAGE__, "Correct package"); +is($@->caller,__PACKAGE__."::__ANON__", "Correct caller"); +is($@->line, $line, "Correct line"); +is($@->args->[1], '<', 'Correct mode arg'); +is($@->args->[2], NO_SUCH_FILE, 'Correct filename arg'); +ok($@->matches('open'), 'Looks like an error from open'); +ok($@->matches(':io'), 'Looks like an error from :io'); +is($@->context, 'scalar', 'Open called in scalar/void context'); +is($@->return,undef,'Open should return undef on failure'); + +# Testing of caller info with a real subroutine. + +my $line2; + +sub xyzzy { + use autodie ':io'; + $line2 = __LINE__; open(my $fh, '<', NO_SUCH_FILE); + return; +}; + +eval { xyzzy(); }; + +isa_ok($@, 'autodie::exception'); +is($@->caller, __PACKAGE__."::xyzzy", "Subroutine caller test"); +is($@->line, $line2, "Subroutine line test"); diff --git a/cpan/autodie/t/binmode.t b/cpan/autodie/t/binmode.t new file mode 100755 index 0000000000..317a41303c --- /dev/null +++ b/cpan/autodie/t/binmode.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w +use strict; +use Test::More 'no_plan'; + +# These are a bunch of general tests for working with files and +# filehandles. + +my $r = "default"; + +eval { + no warnings; + $r = binmode(FOO); +}; + +is($@,"","Sanity: binmode(FOO) doesn't usually throw exceptions"); +is($r,undef,"Sanity: binmode(FOO) returns undef"); + +eval { + use autodie qw(binmode); + no warnings; + binmode(FOO); +}; + +ok($@, "autodie qw(binmode) should cause failing binmode to die."); +isa_ok($@,"autodie::exception", "binmode exceptions are in autodie::exception"); + +eval { + use autodie; + no warnings; + binmode(FOO); +}; + +ok($@, "autodie (default) should cause failing binmode to die."); diff --git a/cpan/autodie/t/blog_hints.t b/cpan/autodie/t/blog_hints.t new file mode 100755 index 0000000000..395cb14342 --- /dev/null +++ b/cpan/autodie/t/blog_hints.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More 'no_plan'; + +use FindBin; +use lib "$FindBin::Bin/lib"; + +use Some::Module qw(some_sub); +use my::autodie qw(! some_sub); + +eval { some_sub() }; + +isnt("$@", "", "some_sub should die in void/scalar context"); + +isa_ok($@, 'autodie::exception'); +is($@->context, 'scalar'); +is($@->function, 'Some::Module::some_sub'); +like("$@", qr/can't be called in scalar context/); + +my @returns = eval { some_sub(0); }; +is($@, "", "Good call to some_sub"); +is_deeply(\@returns, [1,2,3], "Returns unmolested"); + +@returns = eval { some_sub(1) }; + +isnt("$@",""); +is($@->return->[0], undef); +is($@->return->[1], 'Insufficient credit'); +like("$@", qr/Insufficient credit/); diff --git a/cpan/autodie/t/caller.t b/cpan/autodie/t/caller.t new file mode 100755 index 0000000000..1874353627 --- /dev/null +++ b/cpan/autodie/t/caller.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie; +use Test::More 'no_plan'; +use FindBin qw($Bin); +use lib "$Bin/lib"; +use Caller_helper; + +use constant NO_SUCH_FILE => "kiwifoo_is_so_much_fun"; + +eval { + foo(); +}; + +isa_ok($@, 'autodie::exception'); + +is($@->caller, 'main::foo', "Caller should be main::foo"); + +sub foo { + use autodie; + open(my $fh, '<', NO_SUCH_FILE); +} + +eval { + Caller_helper::foo(); +}; + +isa_ok($@, 'autodie::exception'); + +is($@->line, $Caller_helper::line, "External line number check"); +is($@->file, $INC{"Caller_helper.pm"}, "External filename check"); +is($@->package, "Caller_helper", "External package check"); +is($@->caller, "Caller_helper::foo", "External subname check"); diff --git a/cpan/autodie/t/context.t b/cpan/autodie/t/context.t new file mode 100755 index 0000000000..39b86497c6 --- /dev/null +++ b/cpan/autodie/t/context.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w +use strict; + +use Test::More; + +plan 'no_plan'; + +sub list_return { + return if @_; + return qw(foo bar baz); +} + +sub list_return2 { + return if @_; + return qw(foo bar baz); +} + +# Returns a list presented to it, but also returns a single +# undef if given a list of a single undef. This mimics the +# behaviour of many user-defined subs and built-ins (eg: open) that +# always return undef regardless of context. + +sub list_mirror { + return undef if (@_ == 1 and not defined $_[0]); + return @_; + +} + +use Fatal qw(list_return); +use Fatal qw(:void list_return2); + +TODO: { + + # Clobbering context was documented as a bug in the original + # Fatal, so we'll still consider it a bug here. + + local $TODO = "Fatal clobbers context, just like it always has."; + + my @list = list_return(); + + is_deeply(\@list,[qw(foo bar baz)],'fatal sub works in list context'); +} + +eval { + my @line = list_return(1); # Should die +}; + +ok($@,"List return fatalised"); + +### Tests where we've fatalised our function with :void ### + +my @list2 = list_return2(); + +is_deeply(\@list2,[qw(foo bar baz)],'fatal sub works in list context'); + +eval { + my @line = list_return2(1); # Shouldn't die +}; + +ok(! $@,"void List return fatalised survives when non-void"); + +eval { + list_return2(1); +}; + +ok($@,"void List return fatalised"); diff --git a/cpan/autodie/t/context_lexical.t b/cpan/autodie/t/context_lexical.t new file mode 100755 index 0000000000..ce50b75c4b --- /dev/null +++ b/cpan/autodie/t/context_lexical.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl -w +use strict; + +use Test::More; + +plan 'no_plan'; + +# Returns a list presented to it, but also returns a single +# undef if given a list of a single undef. This mimics the +# behaviour of many user-defined subs and built-ins (eg: open) that +# always return undef regardless of context. +# +# We also do an 'empty return' if no arguments are passed. This +# mimics the PBP guideline for returning nothing. + +sub list_mirror { + return undef if (@_ == 1 and not defined $_[0]); + return if not @_; + return @_; + +} + +### autodie clobbering tests ### + +eval { + list_mirror(); +}; + +is($@, "", "No autodie, no fatality"); + +eval { + use autodie qw(list_mirror); + list_mirror(); +}; + +ok($@, "Autodie fatality for empty return in void context"); + +eval { + list_mirror(); +}; + +is($@, "", "No autodie, no fatality (after autodie used)"); + +eval { + use autodie qw(list_mirror); + list_mirror(undef); +}; + +ok($@, "Autodie fatality for undef return in void context"); + +eval { + use autodie qw(list_mirror); + my @list = list_mirror(); +}; + +ok($@,"Autodie fatality for empty list return"); + +eval { + use autodie qw(list_mirror); + my @list = list_mirror(undef); +}; + +ok($@,"Autodie fatality for undef list return"); + +eval { + use autodie qw(list_mirror); + my @list = list_mirror("tada"); +}; + +ok(! $@,"No Autodie fatality for defined list return"); + +eval { + use autodie qw(list_mirror); + my $single = list_mirror("tada"); +}; + +ok(! $@,"No Autodie fatality for defined scalar return"); + +eval { + use autodie qw(list_mirror); + my $single = list_mirror(undef); +}; + +ok($@,"Autodie fatality for undefined scalar return"); diff --git a/cpan/autodie/t/crickey.t b/cpan/autodie/t/crickey.t new file mode 100755 index 0000000000..91a7d7837a --- /dev/null +++ b/cpan/autodie/t/crickey.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w +use strict; +use FindBin; +use Test::More 'no_plan'; + +use lib "$FindBin::Bin/lib"; + +use constant NO_SUCH_FILE => "crickey_mate_this_file_isnt_here_either"; + +use autodie::test::au qw(open); + +eval { + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok(my $e = $@, 'Strewth! autodie::test::au should throw an exception on failure'); + +isa_ok($e, 'autodie::test::au::exception', + 'Yeah mate, that should be our test exception.'); + +like($e, qr/time for a beer/, "Time for a beer mate?"); + +like( eval { $e->time_for_a_beer; }, + qr/time for a beer/, "It's always a good time for a beer." +); + +ok($e->matches('open'), "Should be a fair dinkum error from open"); diff --git a/cpan/autodie/t/dbmopen.t b/cpan/autodie/t/dbmopen.t new file mode 100755 index 0000000000..31698e65be --- /dev/null +++ b/cpan/autodie/t/dbmopen.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl -w +use strict; +use Test::More qw(no_plan); + +use constant ERROR_REGEXP => qr{Can't dbmopen\(%hash, 'foo/bar/baz', 0666\):}; + +my $return = "default"; + +eval { + $return = dbmopen(my %foo, "foo/bar/baz", 0666); +}; + +ok(!$return, "Sanity: dbmopen usually returns false on failure"); +ok(!$@, "Sanity: dbmopen doesn't usually throw exceptions"); + +eval { + use autodie; + + dbmopen(my %foo, "foo/bar/baz", 0666); +}; + +ok($@, "autodie allows dbmopen to throw errors."); +isa_ok($@, "autodie::exception", "... errors are of the correct type"); + +like($@, ERROR_REGEXP, "Message should include number in octal, not decimal"); + +eval { + use autodie; + + my %bar = ( foo => 1, bar => 2 ); + + dbmopen(%bar, "foo/bar/baz", 0666); +}; + +like($@, ERROR_REGEXP, "Correct formatting even with non-empty dbmopen hash"); + diff --git a/cpan/autodie/t/exception_class.t b/cpan/autodie/t/exception_class.t new file mode 100755 index 0000000000..127893bcbf --- /dev/null +++ b/cpan/autodie/t/exception_class.t @@ -0,0 +1,57 @@ +#!/usr/bin/perl -w +use strict; + +use FindBin; +use Test::More 'no_plan'; + +use lib "$FindBin::Bin/lib"; + +use constant NO_SUCH_FILE => "this_file_had_better_not_exist_xyzzy"; + +### Tests with non-existent exception class. + +my $open_success = eval { + use autodie::test::missing qw(open); # Uses non-existent exceptions + open(my $fh, '<', NO_SUCH_FILE); + 1; +}; + +is($open_success,undef,"Open should fail"); + +isnt($@,"",'$@ should not be empty'); + +is(ref($@),"",'$@ should not be a reference or object'); + +like($@, qr/Failed to load/, '$@ should contain bad exception class msg'); + +#### Tests with malformed exception class. + +my $open_success2 = eval { + use autodie::test::badname qw(open); + open(my $fh, '<', NO_SUCH_FILE); + 1; +}; + +is($open_success2,undef,"Open should fail"); + +isnt($@,"",'$@ should not be empty'); + +is(ref($@),"",'$@ should not be a reference or object'); + +like($@, qr/Bad exception class/, '$@ should contain bad exception class msg'); + +### Tests with well-formed exception class (in Klingon) + +my $open_success3 = eval { + use pujHa'ghach qw(open); #' <-- this makes my editor happy + open(my $fh, '<', NO_SUCH_FILE); + 1; +}; + +is($open_success3,undef,"Open should fail"); + +isnt("$@","",'$@ should not be empty'); + +isa_ok($@, "pujHa'ghach::Dotlh", '$@ should be a Klingon exception'); + +like($@, qr/lujqu'/, '$@ should contain Klingon text'); diff --git a/cpan/autodie/t/exceptions.t b/cpan/autodie/t/exceptions.t new file mode 100755 index 0000000000..2f8c2382fc --- /dev/null +++ b/cpan/autodie/t/exceptions.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl -w +use strict; +use Test::More; + +BEGIN { plan skip_all => "Perl 5.10 only tests" if $] < 5.010; } + +# These are tests that depend upon 5.10 (eg, smart-match). +# Basic tests should go in basic_exceptions.t + +use 5.010; +use constant NO_SUCH_FILE => 'this_file_had_better_not_exist_xyzzy'; + +plan 'no_plan'; + +eval { + use autodie ':io'; + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok($@, "Exception thrown" ); +ok($@ ~~ 'open', "Exception from open" ); +ok($@ ~~ ':file', "Exception from open / class :file" ); +ok($@ ~~ ':io', "Exception from open / class :io" ); +ok($@ ~~ ':all', "Exception from open / class :all" ); + +eval { + no warnings 'once'; # To prevent the following close from complaining. + close(THIS_FILEHANDLE_AINT_OPEN); +}; + +ok(! $@, "Close without autodie should fail silent"); + +eval { + use autodie ':io'; + close(THIS_FILEHANDLE_AINT_OPEN); +}; + +like($@, qr{Can't close filehandle 'THIS_FILEHANDLE_AINT_OPEN'},"Nice msg from close"); + +ok($@, "Exception thrown" ); +ok($@ ~~ 'close', "Exception from close" ); +ok($@ ~~ ':file', "Exception from close / class :file" ); +ok($@ ~~ ':io', "Exception from close / class :io" ); +ok($@ ~~ ':all', "Exception from close / class :all" ); + diff --git a/cpan/autodie/t/exec.t b/cpan/autodie/t/exec.t new file mode 100755 index 0000000000..0d4439a8c1 --- /dev/null +++ b/cpan/autodie/t/exec.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 3; + +eval { + use autodie qw(exec); + exec("this_command_had_better_not_exist", 1); +}; + +isa_ok($@,"autodie::exception", "failed execs should die"); +ok($@->matches('exec'), "exception should match exec"); +ok($@->matches(':system'), "exception should match :system"); diff --git a/cpan/autodie/t/filehandles.t b/cpan/autodie/t/filehandles.t new file mode 100755 index 0000000000..5bdf732e2c --- /dev/null +++ b/cpan/autodie/t/filehandles.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl -w + +package main; + +use strict; +use Test::More; + +# We may see failures with package filehandles if Fatal/autodie +# incorrectly pulls out a cached subroutine from a different package. + +# We're using Fatal because package filehandles are likely to +# see more use with Fatal than autodie. + +use Fatal qw(open); + +eval { + open(FILE, '<', $0); +}; + + +if ($@) { + # Holy smokes! We couldn't even open our own file, bail out... + + plan skip_all => q{Can't open $0 for filehandle tests} +} + +plan tests => 4; + +my $line = <FILE>; + +like($line, qr{perl}, 'Looks like we opened $0 correctly'); + +close(FILE); + +package autodie::test; +use Test::More; + +use Fatal qw(open); + +eval { + open(FILE2, '<', $0); +}; + +is($@,"",'Opened $0 in autodie::test'); + +my $line2 = <FILE2>; + +like($line2, qr{perl}, '...and we can read from $0 fine'); + +close(FILE2); + +package main; + +# This shouldn't read anything, because FILE2 should be inside +# autodie::test + +no warnings; # Otherwise we see problems with FILE2 +my $wrong_line = <FILE2>; + +ok(! defined($wrong_line),q{Filehandles shouldn't leak between packages}); diff --git a/cpan/autodie/t/fileno.t b/cpan/autodie/t/fileno.t new file mode 100755 index 0000000000..2b9c2598e7 --- /dev/null +++ b/cpan/autodie/t/fileno.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 8; + +# Basic sanity tests. +is(fileno(STDIN), 0, "STDIN fileno looks sane"); +is(fileno(STDOUT),1, "STDOUT looks sane"); + +my $dummy = "foo"; + +ok(!defined(fileno($dummy)), "Non-filehandles shouldn't be defined."); + + +my $fileno = eval { + use autodie qw(fileno); + fileno(STDIN); +}; + +is($@,"","fileno(STDIN) shouldn't die"); +is($fileno,0,"autodying fileno(STDIN) should be 0"); + +$fileno = eval { + use autodie qw(fileno); + fileno(STDOUT); +}; + +is($@,"","fileno(STDOUT) shouldn't die"); +is($fileno,1,"autodying fileno(STDOUT) should be 1"); + +$fileno = eval { + use autodie qw(fileno); + fileno($dummy); +}; + +isa_ok($@,"autodie::exception", 'autodying fileno($dummy) should die'); diff --git a/cpan/autodie/t/flock.t b/cpan/autodie/t/flock.t new file mode 100755 index 0000000000..a7550bad6a --- /dev/null +++ b/cpan/autodie/t/flock.t @@ -0,0 +1,90 @@ +#!/usr/bin/perl -w +use strict; +use Test::More; +use Fcntl qw(:flock); +use POSIX qw(EWOULDBLOCK); + +require Fatal; + +my $EWOULDBLOCK = eval { EWOULDBLOCK() } + || $Fatal::_EWOULDBLOCK{$^O} + || plan skip_all => "EWOULDBLOCK not defined on this system"; + +my ($self_fh, $self_fh2); + +eval { + use autodie; + open($self_fh, '<', $0); + open($self_fh2, '<', $0); + open(SELF, '<', $0); +}; + +if ($@) { + plan skip_all => "Cannot lock this test on this system."; +} + +my $flock_return = eval { flock($self_fh, LOCK_EX | LOCK_NB); }; + +if (not $flock_return) { + plan skip_all => "flock on my own test not supported on this system."; +} + +my $flock_return2 = flock($self_fh2, LOCK_EX | LOCK_NB); + +if ($flock_return2) { + plan skip_all => "this test requires locking a file twice with ". + "different filehandles to fail"; +} + +$flock_return = flock($self_fh, LOCK_UN); + +if (not $flock_return) { + plan skip_all => "Odd, I can't unlock a file with flock on this system."; +} + +# If we're here, then we can lock and unlock our own file. + +plan 'no_plan'; + +ok( flock($self_fh, LOCK_EX | LOCK_NB), "Test file locked"); + +my $return; + +eval { + use autodie qw(flock); + $return = flock($self_fh2, LOCK_EX | LOCK_NB); +}; + +is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK"); +ok(!$return, "flocking a file twice should fail"); +is($@, "", "Non-blocking flock should not fail on EWOULDBLOCK"); + +__END__ + +# These are old tests which I'd love to resurrect, but they need +# a reliable way of getting flock to throw exceptions but with +# minimal blocking. They may turn into author tests. + +eval { + use autodie; + flock($self_fh2, LOCK_EX | LOCK_NB); +}; + +ok($@, "Locking a file twice throws an exception with vanilla autodie"); +isa_ok($@, "autodie::exception", "Exception is from autodie::exception"); + +like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch"); +like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch"); +unlike($@, qr/GLOB/ , "error doesn't include ugly GLOB mention"); + +eval { + use autodie; + flock(SELF, LOCK_EX | LOCK_NB); +}; + +ok($@, "Locking a package filehanlde twice throws exception with vanilla autodie"); +isa_ok($@, "autodie::exception", "Exception is from autodie::exception"); + +like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch"); +like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch"); +like($@, qr/SELF/ , "error mentions actual filehandle name."); diff --git a/cpan/autodie/t/format-clobber.t b/cpan/autodie/t/format-clobber.t new file mode 100755 index 0000000000..ee8e8bd5c8 --- /dev/null +++ b/cpan/autodie/t/format-clobber.t @@ -0,0 +1,67 @@ +#!/usr/bin/env perl +use warnings; +use strict; + +use FindBin; +use lib "$FindBin::Bin/lib"; +use Test::More tests => 21; + +our ($pvio, $pvfm); + +use_ok('OtherTypes'); + +# Since we use use_ok, this is effectively 'compile time'. + +ok( defined *OtherTypes::foo{SCALAR}, + "SCALAR slot intact at compile time" ); +ok( defined *OtherTypes::foo{ARRAY}, + "ARRAY slot intact at compile time" ); +ok( defined *OtherTypes::foo{HASH}, + "HASH slot intact at compile time" ); +ok( defined *OtherTypes::foo{IO}, + "IO slot intact at compile time" ); +ok( defined *OtherTypes::foo{FORMAT}, + "FORMAT slot intact at compile time" ); + +is( $OtherTypes::foo, 23, + "SCALAR slot correct at compile time" ); +is( $OtherTypes::foo[0], "bar", + "ARRAY slot correct at compile time" ); +is( $OtherTypes::foo{mouse}, "trap", + "HASH slot correct at compile time" ); +is( *OtherTypes::foo{IO}, $pvio, + "IO slot correct at compile time" ); +is( *OtherTypes::foo{FORMAT}, $pvfm, + "FORMAT slot correct at compile time" ); + +eval q{ + ok( defined *OtherTypes::foo{SCALAR}, + "SCALAR slot intact at run time" ); + ok( defined *OtherTypes::foo{ARRAY}, + "ARRAY slot intact at run time" ); + ok( defined *OtherTypes::foo{HASH}, + "HASH slot intact at run time" ); + ok( defined *OtherTypes::foo{IO}, + "IO slot intact at run time" ); + + TODO: { + local $TODO = "Copying formats fails due to a bug in Perl."; + ok( defined *OtherTypes::foo{FORMAT}, + "FORMAT slot intact at run time" ); + } + + is( $OtherTypes::foo, 23, + "SCALAR slot correct at run time" ); + is( $OtherTypes::foo[0], "bar", + "ARRAY slot correct at run time" ); + is( $OtherTypes::foo{mouse}, "trap", + "HASH slot correct at run time" ); + is( *OtherTypes::foo{IO}, $pvio, + "IO slot correct at run time" ); + + TODO: { + local $TODO = "Copying formats fails due to a bug in Perl."; + is( *OtherTypes::foo{FORMAT}, $pvfm, + "FORMAT slot correct at run time" ); + } +}; diff --git a/cpan/autodie/t/hints.t b/cpan/autodie/t/hints.t new file mode 100755 index 0000000000..b508fee235 --- /dev/null +++ b/cpan/autodie/t/hints.t @@ -0,0 +1,155 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie::hints; + +use FindBin; +use lib "$FindBin::Bin/lib"; + +use File::Copy qw(copy move cp mv); + +use Test::More 'no_plan'; + +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; +use constant NO_SUCH_FILE2 => "this_file_had_better_not_exist_xyzzy"; + +use constant PERL510 => ( $] >= 5.0100 ); +use constant PERL5101 => ( $] >= 5.0101 ); +use constant PERL5102 => ( $] >= 5.0102 ); + +# File::Copy states that all subroutines return '0' on failure. +# However both Windows and VMS may return other false values +# (notably empty-string) on failure. This constant indicates +# whether we should skip some tests because the return values +# from File::Copy may not be what's in the documentation. + +use constant WEIRDO_FILE_COPY => + ( ! PERL5102 and ( $^O eq "MSWin32" or $^O eq "VMS" )); + +use Hints_test qw( + fail_on_empty fail_on_false fail_on_undef +); + +use autodie qw(fail_on_empty fail_on_false fail_on_undef); + +diag("Sub::Identify ", exists( $INC{'Sub/Identify.pm'} ) ? "is" : "is not", + " loaded") if (! $ENV{PERL_CORE}); + +my $hints = "autodie::hints"; + +# Basic hinting tests + +is( $hints->sub_fullname(\©), 'File::Copy::copy' , "Id: copy" ); +is( + $hints->sub_fullname(\&cp), + PERL5101 ? 'File::Copy::cp' : 'File::Copy::copy' , "Id: cp" +); + +is( $hints->sub_fullname(\&move), 'File::Copy::move' , "Id: move" ); +is( $hints->sub_fullname(\&mv), + PERL5101 ? 'File::Copy::mv' : 'File::Copy::move' , "Id: mv" +); + +if (PERL510) { + ok( $hints->get_hints_for(\©)->{scalar}->(0) , + "copy() hints should fail on 0 for scalars." + ); + ok( $hints->get_hints_for(\©)->{list}->(0) , + "copy() hints should fail on 0 for lists." + ); +} + +# Scalar context test + +eval { + use autodie qw(copy); + + my $scalar_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2); +}; + +isnt("$@", "", "Copying in scalar context should throw an error."); +isa_ok($@, "autodie::exception"); + +is($@->function, "File::Copy::copy", "Function should be original name"); + +SKIP: { + skip("File::Copy is weird on Win32/VMS before 5.10.1", 1) + if WEIRDO_FILE_COPY; + + is($@->return, 0, "File::Copy returns zero on failure"); +} + +is($@->context, "scalar", "File::Copy called in scalar context"); + +# List context test. + +eval { + use autodie qw(copy); + + my @list_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2); +}; + +isnt("$@", "", "Copying in list context should throw an error."); +isa_ok($@, "autodie::exception"); + +is($@->function, "File::Copy::copy", "Function should be original name"); + +SKIP: { + skip("File::Copy is weird on Win32/VMS before 5.10.1", 1) + if WEIRDO_FILE_COPY; + + is_deeply($@->return, [0], "File::Copy returns zero on failure"); +} +is($@->context, "list", "File::Copy called in list context"); + +# Tests on loaded funcs. + +my %tests = ( + + # Test code # Exception expected? + + 'fail_on_empty()' => 1, + 'fail_on_empty(0)' => 0, + 'fail_on_empty(undef)' => 0, + 'fail_on_empty(1)' => 0, + + 'fail_on_false()' => 1, + 'fail_on_false(0)' => 1, + 'fail_on_false(undef)' => 1, + 'fail_on_false(1)' => 0, + + 'fail_on_undef()' => 1, + 'fail_on_undef(0)' => 0, + 'fail_on_undef(undef)' => 1, + 'fail_on_undef(1)' => 0, + +); + +# On Perl 5.8, autodie doesn't correctly propagate into string evals. +# The following snippet forces the use of autodie inside the eval if +# we really really have to. For 5.10+, we don't want to include this +# fix, because the tests will act as a canary if we screw up string +# eval propagation. + +my $perl58_fix = ( + $] >= 5.010 ? + "" : + "use autodie qw(fail_on_empty fail_on_false fail_on_undef); " +); + +while (my ($test, $exception_expected) = each %tests) { + eval " + $perl58_fix + my \@array = $test; + "; + + + if ($exception_expected) { + isnt("$@", "", $test); + } + else { + is($@, "", $test); + } +} + +1; diff --git a/cpan/autodie/t/hints_insist.t b/cpan/autodie/t/hints_insist.t new file mode 100755 index 0000000000..ab618d2325 --- /dev/null +++ b/cpan/autodie/t/hints_insist.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie; + +use Test::More tests => 5; + +use FindBin qw($Bin); +use lib "$Bin/lib"; + +use Hints_provider_does qw(always_pass always_fail no_hints); + +eval "use autodie qw( ! always_pass always_fail); "; +is("$@", "", "Insisting on good hints (distributed insist)"); + +is(always_pass(), "foo", "Always_pass() should still work"); +is(always_fail(), "foo", "Always_pass() should still work"); + +eval "use autodie qw(!always_pass !always_fail); "; +is("$@", "", "Insisting on good hints (individual insist)"); + +my $ret = eval "use autodie qw(!no_hints); 1;"; +isnt("$@", "", "Asking for non-existent hints"); diff --git a/cpan/autodie/t/hints_pod_examples.t b/cpan/autodie/t/hints_pod_examples.t new file mode 100755 index 0000000000..a3c6f0f553 --- /dev/null +++ b/cpan/autodie/t/hints_pod_examples.t @@ -0,0 +1,184 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie::hints; +use Test::More; + +use constant PERL510 => ( $] >= 5.010 ); + +BEGIN { + if (not PERL510) { + plan skip_all => "Only subroutine hints supported in 5.8.x"; + } + else { + plan 'no_plan'; + } +} + +use FindBin; +use lib "$FindBin::Bin/lib"; +use Hints_pod_examples qw( + undef_scalar false_scalar zero_scalar empty_list default_list + empty_or_false_list undef_n_error_list foo re_fail bar + think_positive my_system +); +use autodie qw( ! + undef_scalar false_scalar zero_scalar empty_list default_list + empty_or_false_list undef_n_error_list foo re_fail bar + think_positive my_system +); + +my %scalar_tests = ( + + # Test code # Exception expected? + + 'undef_scalar()' => 1, + 'undef_scalar(1)', => 0, + 'undef_scalar(0)', => 0, + 'undef_scalar("")', => 0, + + 'false_scalar(0)', => 1, + 'false_scalar()', => 1, + 'false_scalar(undef)', => 1, + 'false_scalar("")', => 1, + 'false_scalar(1)', => 0, + 'false_scalar("1")', => 0, + + 'zero_scalar("0")', => 1, + 'zero_scalar(0)', => 1, + 'zero_scalar(1)', => 0, + 'zero_scalar(undef)', => 0, + 'zero_scalar("")', => 0, + + 'foo(0)', => 1, + 'foo(undef)', => 0, + 'foo(1)', => 0, + + 'bar(0)', => 1, + 'bar(undef)', => 0, + 'bar(1)', => 0, + + 're_fail(-1)', => 0, + 're_fail("FAIL")', => 1, + 're_fail("_FAIL")', => 1, + 're_fail("_fail")', => 0, + 're_fail("fail")', => 0, + + 'think_positive(-1)' => 1, + 'think_positive(-2)' => 1, + 'think_positive(0)' => 0, + 'think_positive(1)' => 0, + 'think_positive(2)' => 0, + + 'my_system(1)' => 1, + 'my_system(2)' => 1, + 'my_system(0)' => 0, + +); + +my %list_tests = ( + + 'empty_list()', => 1, + 'empty_list(())', => 1, + 'empty_list([])', => 0, + 'empty_list(0)', => 0, + 'empty_list("")', => 0, + 'empty_list(undef)', => 0, + + 'default_list()', => 1, + 'default_list(0)', => 0, + 'default_list("")', => 0, + 'default_list(undef)', => 1, + 'default_list(1)', => 0, + 'default_list("str")', => 0, + 'default_list(1, 2)', => 0, + + 'empty_or_false_list()', => 1, + 'empty_or_false_list(())', => 1, + 'empty_or_false_list(0)', => 1, + 'empty_or_false_list(undef)',=> 1, + 'empty_or_false_list("")', => 1, + 'empty_or_false_list("0")', => 1, + 'empty_or_false_list(1,2)', => 0, + 'empty_or_false_list("a")', => 0, + + 'undef_n_error_list(undef, 1)' => 1, + 'undef_n_error_list(undef, "a")' => 1, + 'undef_n_error_list()' => 0, + 'undef_n_error_list(0, 1)' => 0, + 'undef_n_error_list("", 1)' => 0, + 'undef_n_error_list(1)' => 0, + + 'foo(0)', => 1, + 'foo(undef)', => 0, + 'foo(1)', => 0, + + 'bar(0)', => 1, + 'bar(undef)', => 0, + 'bar(1)', => 0, + + 're_fail(-1)', => 1, + 're_fail("FAIL")', => 0, + 're_fail("_FAIL")', => 0, + 're_fail("_fail")', => 0, + 're_fail("fail")', => 0, + + 'think_positive(-1)' => 1, + 'think_positive(-2)' => 1, + 'think_positive(0)' => 0, + 'think_positive(1)' => 0, + 'think_positive(2)' => 0, + + 'my_system(1)' => 1, + 'my_system(2)' => 1, + 'my_system(0)' => 0, + +); + +# On Perl 5.8, autodie doesn't correctly propagate into string evals. +# The following snippet forces the use of autodie inside the eval if +# we really really have to. For 5.10+, we don't want to include this +# fix, because the tests will act as a canary if we screw up string +# eval propagation. + +my $perl58_fix = ( + PERL510 ? + q{} : + q{use autodie qw( + undef_scalar false_scalar zero_scalar empty_list default_list + empty_or_false_list undef_n_error_list foo re_fail bar + think_positive my_system bizarro_system + );} +); + +# Some of the tests provide different hints for scalar or list context + +while (my ($test, $exception_expected) = each %scalar_tests) { + eval " + $perl58_fix + my \$scalar = $test; + "; + + if ($exception_expected) { + isnt("$@", "", "scalar test - $test"); + } + else { + is($@, "", "scalar test - $test"); + } +} + +while (my ($test, $exception_expected) = each %list_tests) { + eval " + $perl58_fix + my \@array = $test; + "; + + if ($exception_expected) { + isnt("$@", "", "array test - $test"); + } + else { + is($@, "", "array test - $test"); + } +} + +1; diff --git a/cpan/autodie/t/hints_provider_does.t b/cpan/autodie/t/hints_provider_does.t new file mode 100755 index 0000000000..a671b73e13 --- /dev/null +++ b/cpan/autodie/t/hints_provider_does.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie; + +use Test::More 'no_plan'; + +use FindBin qw($Bin); +use lib "$Bin/lib"; + +use Hints_provider_does qw(always_pass always_fail); +use autodie qw(always_pass always_fail); + +eval { my $x = always_pass() }; +is("$@", "", "always_pass in scalar context"); + +eval { my @x = always_pass() }; +is("$@", "", "always_pass in list context"); + +eval { my $x = always_fail() }; +isnt("$@", "", "always_fail in scalar context"); + +eval { my @x = always_fail() }; +isnt("$@", "", "always_fail in list context"); diff --git a/cpan/autodie/t/hints_provider_easy_does_it.t b/cpan/autodie/t/hints_provider_easy_does_it.t new file mode 100755 index 0000000000..2606ff8cb3 --- /dev/null +++ b/cpan/autodie/t/hints_provider_easy_does_it.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie; + +use Test::More 'no_plan'; + +use FindBin qw($Bin); +use lib "$Bin/lib"; + +use Hints_provider_easy_does_it qw(always_pass always_fail); +use autodie qw(always_pass always_fail); + +eval { my $x = always_pass() }; +is("$@", "", "always_pass in scalar context"); + +eval { my @x = always_pass() }; +is("$@", "", "always_pass in list context"); + +eval { my $x = always_fail() }; +isnt("$@", "", "always_fail in scalar context"); + +eval { my @x = always_fail() }; +isnt("$@", "", "always_fail in list context"); diff --git a/cpan/autodie/t/hints_provider_isa.t b/cpan/autodie/t/hints_provider_isa.t new file mode 100755 index 0000000000..022b34f525 --- /dev/null +++ b/cpan/autodie/t/hints_provider_isa.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie; + +use Test::More 'no_plan'; + +use FindBin qw($Bin); +use lib "$Bin/lib"; + +use Hints_provider_isa qw(always_pass always_fail); +use autodie qw(always_pass always_fail); + +eval { my $x = always_pass() }; +is("$@", "", "always_pass in scalar context"); + +eval { my @x = always_pass() }; +is("$@", "", "always_pass in list context"); + +eval { my $x = always_fail() }; +isnt("$@", "", "always_fail in scalar context"); + +eval { my @x = always_fail() }; +isnt("$@", "", "always_fail in list context"); diff --git a/cpan/autodie/t/internal-backcompat.t b/cpan/autodie/t/internal-backcompat.t new file mode 100755 index 0000000000..9f7196c3c5 --- /dev/null +++ b/cpan/autodie/t/internal-backcompat.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Fatal; +use Test::More 'no_plan'; + +# Tests to determine if Fatal's internal interfaces remain backwards +# compatible. +# +# WARNING: This file contains a lot of very ugly code, hard-coded +# strings, and nasty API calls. It may frighten small children. +# Viewer discretion is advised. + +# fill_protos. This hasn't been changed since the original Fatal, +# and so should always be the same. + +my %protos = ( + '$' => [ [ 1, '$_[0]' ] ], + '$$' => [ [ 2, '$_[0]', '$_[1]' ] ], + '$$@' => [ [ 3, '$_[0]', '$_[1]', '@_[2..$#_]' ] ], + '\$' => [ [ 1, '${$_[0]}' ] ], + '\%' => [ [ 1, '%{$_[0]}' ] ], + '\%;$*' => [ [ 1, '%{$_[0]}' ], [ 2, '%{$_[0]}', '$_[1]' ], + [ 3, '%{$_[0]}', '$_[1]', '$_[2]' ] ], +); + +while (my ($proto, $code) = each %protos) { + is_deeply( [ Fatal::fill_protos($proto) ], $code, $proto); +} + +# write_invocation tests +no warnings 'qw'; + +# Technically the outputted code varies from the classical Fatal. +# However the changes are mostly whitespace. Those that aren't are +# improvements to error messages. + +my @write_invocation_calls = ( + [ + # Core # Call # Name # Void # Args + [ 1, 'CORE::open', 'open', 0, [ 1, qw($_[0]) ], + [ 2, qw($_[0] $_[1]) ], + [ 3, qw($_[0] $_[1] @_[2..$#_])] + ], + q{ if (@_ == 1) { +return CORE::open($_[0]) || croak "Can't open(@_): $!" } elsif (@_ == 2) { +return CORE::open($_[0], $_[1]) || croak "Can't open(@_): $!" } elsif (@_ == 3) { +return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!" + } + die "Internal error: open(@_): Do not expect to get ", scalar(@_), " arguments"; + } + ] +); + +foreach my $test (@write_invocation_calls) { + is(Fatal::write_invocation( @{ $test->[0] } ), $test->[1], 'write_inovcation'); +} + +# one_invocation tests. + +my @one_invocation_calls = ( + # Core # Call # Name # Void # Args + [ + [ 1, 'CORE::open', 'open', 0, qw($_[0] $_[1] @_[2..$#_]) ], + q{return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"}, + ], + [ + [ 1, 'CORE::open', 'open', 1, qw($_[0] $_[1] @_[2..$#_]) ], + q{return (defined wantarray)?CORE::open($_[0], $_[1], @_[2..$#_]): + CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"}, + ], +); + +foreach my $test (@one_invocation_calls) { + is(Fatal::one_invocation( @{ $test->[0] } ), $test->[1], 'one_inovcation'); +} + +# TODO: _make_fatal +# Since this subroutine has always started with an underscore, +# I think it's pretty clear that it's internal-only. I'm not +# testing it here, and it doesn't yet have backcompat. diff --git a/cpan/autodie/t/internal.t b/cpan/autodie/t/internal.t new file mode 100755 index 0000000000..c1189444cb --- /dev/null +++ b/cpan/autodie/t/internal.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w +use strict; + +use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY"; + +use Test::More tests => 6; + +# Lexical tests using the internal interface. + +eval { Fatal->import(qw(:lexical :void)) }; +like($@, qr{:void cannot be used with lexical}, ":void can't be used with :lexical"); + +eval { Fatal->import(qw(open close :lexical)) }; +like($@, qr{:lexical must be used as first}, ":lexical must come first"); + +{ + use Fatal qw(:lexical chdir); + + eval { chdir(NO_SUCH_FILE); }; + like ($@, qr/^Can't chdir/, "Lexical fatal chdir"); + + no Fatal qw(:lexical chdir); + + eval { chdir(NO_SUCH_FILE); }; + is ($@, "", "No lexical fatal chdir"); + +} + +eval { chdir(NO_SUCH_FILE); }; +is($@, "", "Lexical chdir becomes non-fatal out of scope."); + +eval { Fatal->import('2+2'); }; +like($@,qr{Bad subroutine name},"Can't use fatal with invalid sub names"); diff --git a/cpan/autodie/t/lethal.t b/cpan/autodie/t/lethal.t new file mode 100755 index 0000000000..244d2f82b2 --- /dev/null +++ b/cpan/autodie/t/lethal.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl -w +use strict; +use FindBin; +use Test::More tests => 4; +use lib "$FindBin::Bin/lib"; +use lethal qw(open); + +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; + +eval { + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok($@, "lethal throws an exception"); +isa_ok($@, 'autodie::exception','...which is the correct class'); +ok($@->matches('open'), "...which matches open"); +is($@->file,__FILE__, "...which reports the correct file"); diff --git a/cpan/autodie/t/lib/Caller_helper.pm b/cpan/autodie/t/lib/Caller_helper.pm new file mode 100644 index 0000000000..6ee9c69c07 --- /dev/null +++ b/cpan/autodie/t/lib/Caller_helper.pm @@ -0,0 +1,13 @@ +package Caller_helper; + +our $line; + +sub foo { + use autodie; + + $line = __LINE__; open(my $fh, '<', "no_such_file_here"); + + return; +} + +1; diff --git a/cpan/autodie/t/lib/Hints_pod_examples.pm b/cpan/autodie/t/lib/Hints_pod_examples.pm new file mode 100644 index 0000000000..d88d98e106 --- /dev/null +++ b/cpan/autodie/t/lib/Hints_pod_examples.pm @@ -0,0 +1,108 @@ +package Hints_pod_examples; +use strict; +use warnings; + +use base qw(Exporter); + +our %DOES = ( 'autodie::hints::provider' => 1 ); + +our @EXPORT_OK = qw( + undef_scalar false_scalar zero_scalar empty_list default_list + empty_or_false_list undef_n_error_list foo re_fail bar + think_positive my_system bizarro_system +); + +use autodie::hints; + +sub AUTODIE_HINTS { + return { + # Scalar failures always return undef: + undef_scalar => { fail => undef }, + + # Scalar failures return any false value [default behaviour]: + false_scalar => { fail => sub { return ! $_[0] } }, + + # Scalar failures always return zero explicitly: + zero_scalar => { fail => '0' }, + + # List failures always return empty list: + # We never want these called in a scalar context + empty_list => { scalar => sub { 1 }, list => [] }, + + # List failures return C<()> or C<(undef)> [default expectation]: + default_list => { fail => sub { ! @_ || @_ == 1 && !defined $_[0] } }, + + # List failures return C<()> or a single false value: + empty_or_false_list => { fail => sub { ! @_ || @_ == 1 && !$_[0] } }, + + # List failures return (undef, "some string") + undef_n_error_list => { fail => sub { @_ == 2 && !defined $_[0] } }, + }; +} + +# Define some subs that all just return their arguments +sub undef_scalar { return wantarray ? @_ : $_[0] } +sub false_scalar { return wantarray ? @_ : $_[0] } +sub zero_scalar { return wantarray ? @_ : $_[0] } +sub empty_list { return wantarray ? @_ : $_[0] } +sub default_list { return wantarray ? @_ : $_[0] } +sub empty_or_false_list { return wantarray ? @_ : $_[0] } +sub undef_n_error_list { return wantarray ? @_ : $_[0] } + + +# Unsuccessful foo() returns 0 in all contexts... +autodie::hints->set_hints_for( + \&foo, + { + scalar => 0, + list => [0], + } +); + +sub foo { return wantarray ? @_ : $_[0] } + +# Unsuccessful re_fail() returns 'FAIL' or '_FAIL' in scalar context, +# returns (-1) in list context... +autodie::hints->set_hints_for( + \&re_fail, + { + scalar => qr/^ _? FAIL $/xms, + list => [-1], + } +); + +sub re_fail { return wantarray ? @_ : $_[0] } + +# Unsuccessful bar() returns 0 in all contexts... +autodie::hints->set_hints_for( + \&bar, + { + scalar => 0, + list => [0], + } +); + +sub bar { return wantarray ? @_ : $_[0] } + +# Unsuccessful think_positive() returns negative number on failure... +autodie::hints->set_hints_for( + \&think_positive, + { + scalar => sub { $_[0] < 0 }, + list => sub { $_[0] < 0 }, + } +); + +sub think_positive { return wantarray ? @_ : $_[0] } + +# Unsuccessful my_system() returns non-zero on failure... +autodie::hints->set_hints_for( + \&my_system, + { + scalar => sub { $_[0] != 0 }, + list => sub { $_[0] != 0 }, + } +); +sub my_system { return wantarray ? @_ : $_[0] }; + +1; diff --git a/cpan/autodie/t/lib/Hints_provider_does.pm b/cpan/autodie/t/lib/Hints_provider_does.pm new file mode 100644 index 0000000000..403e4b49f7 --- /dev/null +++ b/cpan/autodie/t/lib/Hints_provider_does.pm @@ -0,0 +1,29 @@ +package Hints_provider_does; +use strict; +use warnings; +use base qw(Exporter); + +our @EXPORT_OK = qw(always_fail always_pass no_hints); + +sub DOES { + my ($class, $arg) = @_; + + return 1 if ($arg eq 'autodie::hints::provider'); + return $class->SUPER::DOES($arg) if $class->SUPER::can('DOES'); + return $class->isa($arg); +} + +my $package = __PACKAGE__; + +sub AUTODIE_HINTS { + return { + always_fail => { list => sub { 1 }, scalar => sub { 1 } }, + always_pass => { list => sub { 0 }, scalar => sub { 0 } }, + }; +} + +sub always_fail { return "foo" }; +sub always_pass { return "foo" }; +sub no_hints { return "foo" }; + +1; diff --git a/cpan/autodie/t/lib/Hints_provider_easy_does_it.pm b/cpan/autodie/t/lib/Hints_provider_easy_does_it.pm new file mode 100644 index 0000000000..27dbcb2425 --- /dev/null +++ b/cpan/autodie/t/lib/Hints_provider_easy_does_it.pm @@ -0,0 +1,23 @@ +package Hints_provider_easy_does_it; +use strict; +use warnings; +use base qw(Exporter); + +our @EXPORT_OK = qw(always_fail always_pass no_hints); + +our %DOES = ( 'autodie::hints::provider' => 1 ); + +my $package = __PACKAGE__; + +sub AUTODIE_HINTS { + return { + always_fail => { list => sub { 1 }, scalar => sub { 1 } }, + always_pass => { list => sub { 0 }, scalar => sub { 0 } }, + }; +} + +sub always_fail { return "foo" }; +sub always_pass { return "foo" }; +sub no_hints { return "foo" }; + +1; diff --git a/cpan/autodie/t/lib/Hints_provider_isa.pm b/cpan/autodie/t/lib/Hints_provider_isa.pm new file mode 100644 index 0000000000..ad15e3b258 --- /dev/null +++ b/cpan/autodie/t/lib/Hints_provider_isa.pm @@ -0,0 +1,25 @@ +package Hints_provider_isa; +use strict; +use warnings; +use base qw(Exporter); + +our @EXPORT_OK = qw(always_fail always_pass no_hints); + +{ package autodie::hints::provider; } + +push(our @ISA, 'autodie::hints::provider'); + +my $package = __PACKAGE__; + +sub AUTODIE_HINTS { + return { + always_fail => { list => sub { 1 }, scalar => sub { 1 } }, + always_pass => { list => sub { 0 }, scalar => sub { 0 } }, + }; +} + +sub always_fail { return "foo" }; +sub always_pass { return "foo" }; +sub no_hints { return "foo" }; + +1; diff --git a/cpan/autodie/t/lib/Hints_test.pm b/cpan/autodie/t/lib/Hints_test.pm new file mode 100644 index 0000000000..40107880cd --- /dev/null +++ b/cpan/autodie/t/lib/Hints_test.pm @@ -0,0 +1,42 @@ +package Hints_test; +use strict; +use warnings; + +use base qw(Exporter); + +our @EXPORT_OK = qw( + fail_on_empty fail_on_false fail_on_undef +); + +use autodie::hints; + +# Create some dummy subs that just return their arguments. + +sub fail_on_empty { return @_; } +sub fail_on_false { return @_; } +sub fail_on_undef { return @_; } + +# Set them to different failure modes when used with autodie. + +autodie::hints->set_hints_for( + \&fail_on_empty, { + list => autodie::hints::EMPTY_ONLY , + scalar => autodie::hints::EMPTY_ONLY + } +); + +autodie::hints->set_hints_for( + \&fail_on_false, { + list => autodie::hints::EMPTY_OR_FALSE , + scalar => autodie::hints::EMPTY_OR_FALSE + } +); + +autodie::hints->set_hints_for( + \&fail_on_undef, { + list => autodie::hints::EMPTY_OR_UNDEF , + scalar => autodie::hints::EMPTY_OR_UNDEF + } +); + +1; diff --git a/cpan/autodie/t/lib/OtherTypes.pm b/cpan/autodie/t/lib/OtherTypes.pm new file mode 100644 index 0000000000..122a356d9f --- /dev/null +++ b/cpan/autodie/t/lib/OtherTypes.pm @@ -0,0 +1,22 @@ +package OtherTypes; +no warnings; + +our $foo = 23; +our @foo = "bar"; +our %foo = (mouse => "trap"); +open foo, "<", $0; + +format foo = +foo +. + +BEGIN { + $main::pvio = *foo{IO}; + $main::pvfm = *foo{FORMAT}; +} + +sub foo { 1 } + +use autodie 'foo'; + +1; diff --git a/cpan/autodie/t/lib/Some/Module.pm b/cpan/autodie/t/lib/Some/Module.pm new file mode 100644 index 0000000000..a24ec93f66 --- /dev/null +++ b/cpan/autodie/t/lib/Some/Module.pm @@ -0,0 +1,21 @@ +package Some::Module; +use strict; +use warnings; +use base qw(Exporter); + +our @EXPORT_OK = qw(some_sub); + +# This is an example of a subroutine that returns (undef, $msg) +# to signal failure. + +sub some_sub { + my ($arg) = @_; + + if ($arg) { + return (undef, "Insufficient credit"); + } + + return (1,2,3); +} + +1; diff --git a/cpan/autodie/t/lib/autodie/test/au.pm b/cpan/autodie/t/lib/autodie/test/au.pm new file mode 100644 index 0000000000..7a50e8f101 --- /dev/null +++ b/cpan/autodie/t/lib/autodie/test/au.pm @@ -0,0 +1,14 @@ +package autodie::test::au; +use strict; +use warnings; + +use base qw(autodie); + +use autodie::test::au::exception; + +sub throw { + my ($this, @args) = @_; + return autodie::test::au::exception->new(@args); +} + +1; diff --git a/cpan/autodie/t/lib/autodie/test/au/exception.pm b/cpan/autodie/t/lib/autodie/test/au/exception.pm new file mode 100644 index 0000000000..5811fc1ea6 --- /dev/null +++ b/cpan/autodie/t/lib/autodie/test/au/exception.pm @@ -0,0 +1,19 @@ +package autodie::test::au::exception; +use strict; +use warnings; + +use base qw(autodie::exception); + +sub time_for_a_beer { + return "Now's a good time for a beer."; +} + +sub stringify { + my ($this) = @_; + + my $base_str = $this->SUPER::stringify; + + return "$base_str\n" . $this->time_for_a_beer; +} + +1; diff --git a/cpan/autodie/t/lib/autodie/test/badname.pm b/cpan/autodie/t/lib/autodie/test/badname.pm new file mode 100644 index 0000000000..2a621a9112 --- /dev/null +++ b/cpan/autodie/t/lib/autodie/test/badname.pm @@ -0,0 +1,8 @@ +package autodie::test::badname; +use base qw(autodie); + +sub exception_class { + return 'autodie::test::badname::$@#%'; # Doesn't exist! +} + +1; diff --git a/cpan/autodie/t/lib/autodie/test/missing.pm b/cpan/autodie/t/lib/autodie/test/missing.pm new file mode 100644 index 0000000000..b6166a53a4 --- /dev/null +++ b/cpan/autodie/t/lib/autodie/test/missing.pm @@ -0,0 +1,8 @@ +package autodie::test::missing; +use base qw(autodie); + +sub exception_class { + return "autodie::test::missing::exception"; # Doesn't exist! +} + +1; diff --git a/cpan/autodie/t/lib/lethal.pm b/cpan/autodie/t/lib/lethal.pm new file mode 100644 index 0000000000..a49600a58a --- /dev/null +++ b/cpan/autodie/t/lib/lethal.pm @@ -0,0 +1,8 @@ +package lethal; + +# A dummy package showing how we can trivially subclass autodie +# to our tastes. + +use base qw(autodie); + +1; diff --git a/cpan/autodie/t/lib/my/autodie.pm b/cpan/autodie/t/lib/my/autodie.pm new file mode 100644 index 0000000000..1ad12505a4 --- /dev/null +++ b/cpan/autodie/t/lib/my/autodie.pm @@ -0,0 +1,30 @@ +package my::autodie; +use strict; +use warnings; + +use base qw(autodie); +use autodie::exception; +use autodie::hints; + +autodie::hints->set_hints_for( + 'Some::Module::some_sub' => { + scalar => sub { 1 }, # No calling in scalar/void context + list => sub { @_ == 2 and not defined $_[0] } + }, +); + +autodie::exception->register( + 'Some::Module::some_sub' => sub { + my ($E) = @_; + + if ($E->context eq "scalar") { + return "some_sub() can't be called in scalar context"; + } + + my $error = $E->return->[1]; + + return "some_sub() failed: $error"; + } +); + +1; diff --git a/cpan/autodie/t/lib/pujHa/ghach.pm b/cpan/autodie/t/lib/pujHa/ghach.pm new file mode 100644 index 0000000000..a55164b1a2 --- /dev/null +++ b/cpan/autodie/t/lib/pujHa/ghach.pm @@ -0,0 +1,26 @@ +package pujHa'ghach; + +# Translator notes: reH Hegh is Kligon for "always dying". +# It was the original name for this testing pragma, but +# it lacked an apostrophe, which better shows how Perl is +# useful in Klingon naming schemes. + +# The new name is pujHa'ghach is "thing which is not weak". +# puj -> be weak (verb) +# -Ha' -> not +# ghach -> normalise -Ha' verb into noun. +# +# I'm not use if -wI' should be used here. pujwI' is "thing which +# is weak". One could conceivably use "pujHa'wI'" for "thing which +# is not weak". + +use strict; +use warnings; + +use base qw(autodie); + +sub exception_class { + return "pujHa'ghach::Dotlh"; # Dotlh - status +} + +1; diff --git a/cpan/autodie/t/lib/pujHa/ghach/Dotlh.pm b/cpan/autodie/t/lib/pujHa/ghach/Dotlh.pm new file mode 100644 index 0000000000..c7bbf8b1f6 --- /dev/null +++ b/cpan/autodie/t/lib/pujHa/ghach/Dotlh.pm @@ -0,0 +1,59 @@ +package pujHa'ghach::Dotlh; + +# Translator notes: Dotlh = status + +# Ideally this should be le'wI' - Thing that is exceptional. ;) +# Unfortunately that results in a file called .pm, which may cause +# problems on some filesystems. + +use strict; +use warnings; + +use base qw(autodie::exception); + +sub stringify { + my ($this) = @_; + + my $error = $this->SUPER::stringify; + + return "QaghHommeyHeylIjmo':\n" . # Due to your apparent minor errors + "$error\n" . + "lujqu'"; # Epic fail + + +} + +1; + +__END__ + +# The following was a really neat idea, but currently autodie +# always pushes values in $! to format them, which loses the +# Klingon translation. + +use Errno qw(:POSIX); +use Scalar::Util qw(dualvar); + +my %translation_for = ( + EPERM() => q{Dachaw'be'}, # You do not have permission + ENOENT() => q{De' vItu'laHbe'}, # I cannot find this information. +); + +sub errno { + my ($this) = @_; + + my $errno = int $this->SUPER::errno; + + warn "In tlhIngan errno - $errno\n"; + + if ( my $tlhIngan = $translation_for{ $errno } ) { + return dualvar( $errno, $tlhIngan ); + } + + return $!; + +} + +1; + + diff --git a/cpan/autodie/t/mkdir.t b/cpan/autodie/t/mkdir.t new file mode 100755 index 0000000000..7bd6529086 --- /dev/null +++ b/cpan/autodie/t/mkdir.t @@ -0,0 +1,69 @@ +#!/usr/bin/perl -w +use strict; +use Test::More; +use FindBin qw($Bin); +use constant TMPDIR => "$Bin/mkdir_test_delete_me"; + +# Delete our directory if it's there +rmdir TMPDIR; + +# See if we can create directories and remove them +mkdir TMPDIR or plan skip_all => "Failed to make test directory"; + +# Test the directory was created +-d TMPDIR or plan skip_all => "Failed to make test directory"; + +# Try making it a second time (this should fail) +if(mkdir TMPDIR) { plan skip_all => "Attempt to remake a directory succeeded";} + +# See if we can remove the directory +rmdir TMPDIR or plan skip_all => "Failed to remove directory"; + +# Check that the directory was removed +if(-d TMPDIR) { plan skip_all => "Failed to delete test directory"; } + +# Try to delete second time +if(rmdir TMPDIR) { plan skip_all => "Able to rmdir directory twice"; } + +plan tests => 12; + +# Create a directory (this should succeed) +eval { + use autodie; + + mkdir TMPDIR; +}; +is($@, "", "mkdir returned success"); +ok(-d TMPDIR, "Successfully created test directory"); + +# Try to create it again (this should fail) +eval { + use autodie; + + mkdir TMPDIR; +}; +ok($@, "Re-creating directory causes failure."); +isa_ok($@, "autodie::exception", "... errors are of the correct type"); +ok($@->matches("mkdir"), "... it's also a mkdir object"); +ok($@->matches(":filesys"), "... and a filesys object"); + +# Try to delete directory (this should succeed) +eval { + use autodie; + + rmdir TMPDIR; +}; +is($@, "", "rmdir returned success"); +ok(! -d TMPDIR, "Successfully removed test directory"); + +# Try to delete directory again (this should fail) +eval { + use autodie; + + rmdir TMPDIR; +}; +ok($@, "Re-deleting directory causes failure."); +isa_ok($@, "autodie::exception", "... errors are of the correct type"); +ok($@->matches("rmdir"), "... it's also a rmdir object"); +ok($@->matches(":filesys"), "... and a filesys object"); + diff --git a/cpan/autodie/t/open.t b/cpan/autodie/t/open.t new file mode 100755 index 0000000000..9964ba0350 --- /dev/null +++ b/cpan/autodie/t/open.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl -w +use strict; + +use Test::More 'no_plan'; + +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; + +use autodie; + +eval { open(my $fh, '<', NO_SUCH_FILE); }; +ok($@, "3-arg opening non-existent file fails"); +like($@, qr/for reading/, "Well-formatted 3-arg open failure"); + +eval { open(my $fh, "< ".NO_SUCH_FILE) }; +ok($@, "2-arg opening non-existent file fails"); + +like($@, qr/for reading/, "Well-formatted 2-arg open failure"); +unlike($@, qr/GLOB\(0x/, "No ugly globs in 2-arg open messsage"); + +# RT 47520. 2-argument open without mode would repeat the file +# and line number. + +eval { + use autodie; + + open(my $fh, NO_SUCH_FILE); +}; + +isa_ok($@, 'autodie::exception'); +like( $@, qr/at \S+ line \d+/, "At least one mention"); +unlike($@, qr/at \S+ line \d+\s+at \S+ line \d+/, "...but not too mentions"); + +# RT 47520-ish. 2-argument open without a mode should be marked +# as 'for reading'. +like($@, qr/for reading/, "Well formatted 2-arg open without mode"); + +# We also shouldn't get repeated messages, even if the default mode +# was used. Single-arg open always falls through to the default +# formatter. + +eval { + use autodie; + + open( NO_SUCH_FILE . "" ); +}; + +isa_ok($@, 'autodie::exception'); +like( $@, qr/at \S+ line \d+/, "At least one mention"); +unlike($@, qr/at \S+ line \d+\s+at \S+ line \d+/, "...but not too mentions"); diff --git a/cpan/autodie/t/recv.t b/cpan/autodie/t/recv.t new file mode 100755 index 0000000000..cfaa679144 --- /dev/null +++ b/cpan/autodie/t/recv.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 8; +use Socket; +use autodie qw(socketpair); + +# All of this code is based around recv returning an empty +# string when it gets data from a local machine (using AF_UNIX), +# but returning an undefined value on error. Fatal/autodie +# should be able to tell the difference. + +$SIG{PIPE} = 'IGNORE'; + +my ($sock1, $sock2); +socketpair($sock1, $sock2, AF_UNIX, SOCK_STREAM, PF_UNSPEC); + +my $buffer; +send($sock1, "xyz", 0); +my $ret = recv($sock2, $buffer, 2, 0); + +use autodie qw(recv); + +SKIP: { + + skip('recv() never returns empty string with socketpair emulation',4) + if ($ret); + + is($buffer,'xy',"recv() operational without autodie"); + + # Read the last byte from the socket. + eval { $ret = recv($sock2, $buffer, 1, 0); }; + + is($@, "", "recv should not die on returning an emtpy string."); + + is($buffer,"z","recv() operational with autodie"); + is($ret,"","recv returns undying empty string for local sockets"); + +} + +eval { + # STDIN isn't a socket, so this should fail. + recv(STDIN,$buffer,1,0); +}; + +ok($@,'recv dies on returning undef'); +isa_ok($@,'autodie::exception'); + +$buffer = "# Not an empty string\n"; + +# Terminate writing for $sock1 +shutdown($sock1, 1); + +eval { + use autodie qw(send); + # Writing to a socket terminated for writing should fail. + send($sock1,$buffer,0); +}; + +ok($@,'send dies on returning undef'); +isa_ok($@,'autodie::exception'); diff --git a/cpan/autodie/t/repeat.t b/cpan/autodie/t/repeat.t new file mode 100755 index 0000000000..5f85f1218c --- /dev/null +++ b/cpan/autodie/t/repeat.t @@ -0,0 +1,19 @@ +#!/usr/bin/perl -w +use strict; +use Test::More 'no_plan'; +use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; + +eval { + use autodie qw(open open open); + open(my $fh, '<', NO_SUCH_FILE); +}; + +isa_ok($@,q{autodie::exception}); +ok($@->matches('open'),"Exception from open"); + +eval { + open(my $fh, '<', NO_SUCH_FILE); +}; + +is($@,"","Repeated autodie should not leak"); + diff --git a/cpan/autodie/t/scope_leak.t b/cpan/autodie/t/scope_leak.t new file mode 100755 index 0000000000..529daa3ecd --- /dev/null +++ b/cpan/autodie/t/scope_leak.t @@ -0,0 +1,78 @@ +#!/usr/bin/perl -w +use strict; +use FindBin; + +# Check for %^H leaking across file boundries. Many thanks +# to chocolateboy for pointing out this can be a problem. + +use lib $FindBin::Bin; + +use Test::More 'no_plan'; + +use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; +use autodie qw(open); + +eval { + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok($@, "basic autodie test"); + +use autodie_test_module; + +# If things don't work as they should, then the file we've +# just loaded will still have an autodying main::open (although +# its own open should be unaffected). + +eval { + leak_test(NO_SUCH_FILE); +}; + +is($@,"","autodying main::open should not leak to other files"); + +eval { + autodie_test_module::your_open(NO_SUCH_FILE); +}; + +is($@,"","Other package open should be unaffected"); + +# Due to odd filenames reported when doing string evals, +# older versions of autodie would not propogate into string evals. + +eval q{ + open(my $fh, '<', NO_SUCH_FILE); +}; + +TODO: { + local $TODO = "No known way of propagating into string eval in 5.8" + if $] < 5.010; + + ok($@, "Failing-open string eval should throw an exception"); + isa_ok($@, 'autodie::exception'); +} + +eval q{ + no autodie; + + open(my $fh, '<', NO_SUCH_FILE); +}; + +is("$@","","disabling autodie in string context should work"); + +eval { + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok($@,"...but shouldn't disable it for the calling code."); +isa_ok($@, 'autodie::exception'); + +eval q{ + no autodie; + + use autodie qw(open); + + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok($@,"Wacky flipping of autodie in string eval should work too!"); +isa_ok($@, 'autodie::exception'); diff --git a/cpan/autodie/t/string-eval-basic.t b/cpan/autodie/t/string-eval-basic.t new file mode 100755 index 0000000000..62e55006ea --- /dev/null +++ b/cpan/autodie/t/string-eval-basic.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More tests => 3; + +use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; + +# Keep this test alone in its file as it can be hidden by using autodie outside +# the eval. + +# Just to make sure we're absolutely not encountering any weird $@ clobbering +# events, we'll capture a result from our string eval. + +my $result = eval q{ + use autodie "open"; + + open(my $fh, '<', NO_SUCH_FILE); + + 1; +}; + +ok( ! $result, "Eval should fail with autodie/no such file"); +ok($@, "enabling autodie in string eval should throw an exception"); +isa_ok($@, 'autodie::exception'); diff --git a/cpan/autodie/t/string-eval-leak.t b/cpan/autodie/t/string-eval-leak.t new file mode 100755 index 0000000000..329bcfa40e --- /dev/null +++ b/cpan/autodie/t/string-eval-leak.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More tests => 2; + +# Under Perl 5.10.x, a string eval can cause a copy to be taken of +# %^H, which delays stringification of our scope guard objects, +# which in turn causes autodie to leak. These tests check to see +# if we've successfully worked around this issue. + +eval { + + { + use autodie; + eval "1"; + } + + open(my $fh, '<', 'this_file_had_better_not_exist'); +}; + +TODO: { + local $TODO; + + if ( $] >= 5.010 ) { + $TODO = "Autodie can leak near string evals in 5.10.x"; + } + + is("$@","","Autodie should not leak out of scope"); +} + +# However, we can plug the leak with 'no autodie'. + +no autodie; + +eval { + open(my $fh, '<', 'this_file_had_better_not_exist'); +}; + +is("$@","",'no autodie should be able to workaround this bug'); diff --git a/cpan/autodie/t/sysopen.t b/cpan/autodie/t/sysopen.t new file mode 100755 index 0000000000..ab489b7830 --- /dev/null +++ b/cpan/autodie/t/sysopen.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w +use strict; +use Test::More 'no_plan'; +use Fcntl; + +use autodie qw(sysopen); + +use constant NO_SUCH_FILE => "this_file_had_better_not_be_here_at_all"; + +my $fh; +eval { + sysopen($fh, $0, O_RDONLY); +}; + +is($@, "", "sysopen can open files that exist"); + +like(scalar( <$fh> ), qr/perl/, "Data in file read"); + +eval { + sysopen(my $fh2, NO_SUCH_FILE, O_RDONLY); +}; + +isa_ok($@, 'autodie::exception', 'Opening a bad file fails with sysopen'); diff --git a/cpan/autodie/t/truncate.t b/cpan/autodie/t/truncate.t new file mode 100755 index 0000000000..e69ee32d2e --- /dev/null +++ b/cpan/autodie/t/truncate.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl -w +use strict; + +use Test::More; +use File::Temp qw(tempfile); +use IO::Handle; + +my $tmpfh = tempfile(); +my $truncate_status; + +eval { + $truncate_status = truncate($tmpfh, 0); +}; + +if ($@ || !defined($truncate_status)) { + plan skip_all => 'Truncate not implemented or not working on this system'; +} + +plan tests => 3; + +SKIP: { + my $can_truncate_stdout = truncate(\*STDOUT,0); + + if ($can_truncate_stdout) { + skip("This system thinks we can truncate STDOUT. Suuure!", 1); + } + + eval { + use autodie; + truncate(\*STDOUT,0); + }; + + isa_ok($@, 'autodie::exception', "Truncating STDOUT should throw an exception"); + +} + +eval { + use autodie; + no warnings 'once'; + truncate(\*FOO, 0); +}; + +isa_ok($@, 'autodie::exception', "Truncating an unopened file is wrong."); + +$tmpfh->print("Hello World"); +$tmpfh->flush; + +eval { + use autodie; + truncate($tmpfh, 0); +}; + +is($@, "", "Truncating a normal file should be fine"); diff --git a/cpan/autodie/t/unlink.t b/cpan/autodie/t/unlink.t new file mode 100755 index 0000000000..f301500fda --- /dev/null +++ b/cpan/autodie/t/unlink.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl -w +use strict; +use Test::More; +use FindBin qw($Bin); +use constant TMPFILE => "$Bin/unlink_test_delete_me"; + +# Create a file to practice unlinking +open(my $fh, ">", TMPFILE) + or plan skip_all => "Unable to create test file: $!"; +print {$fh} "Test\n"; +close $fh; + +# Check that file now exists +-e TMPFILE or plan skip_all => "Failed to create test file"; + +# Check we can unlink +unlink TMPFILE; + +# Check it's gone +if(-e TMPFILE) {plan skip_all => "Failed to delete test file: $!";} + +# Re-create file +open(my $fh2, ">", TMPFILE) + or plan skip_all => "Unable to create test file: $!"; +print {$fh2} "Test\n"; +close $fh2; + +# Check that file now exists +-e TMPFILE or plan skip_all => "Failed to create test file"; + +plan tests => 6; + +# Try to delete directory (this should succeed) +eval { + use autodie; + + unlink TMPFILE; +}; +is($@, "", "Unlink appears to have been successful"); +ok(! -e TMPFILE, "File does not exist"); + +# Try to delete file again (this should fail) +eval { + use autodie; + + unlink TMPFILE; +}; +ok($@, "Re-unlinking file causes failure."); +isa_ok($@, "autodie::exception", "... errors are of the correct type"); +ok($@->matches("unlink"), "... it's also a unlink object"); +ok($@->matches(":filesys"), "... and a filesys object"); + diff --git a/cpan/autodie/t/user-context.t b/cpan/autodie/t/user-context.t new file mode 100755 index 0000000000..65b6a8876a --- /dev/null +++ b/cpan/autodie/t/user-context.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More 'no_plan'; +use File::Copy; +use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; +use constant EXCEPTION => 'autodie::exception'; + +# http://perlmonks.org/?node_id=744246 describes a situation where +# using autodie on user-defined functions can fail, depending upon +# their context. These tests attempt to detect this bug. + +eval { + use autodie qw(copy); + copy(NO_SUCH_FILE, 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"Copying a non-existent file should throw an error"); + +eval { + use autodie qw(copy); + my $x = copy(NO_SUCH_FILE, 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"This shouldn't change with scalar context"); + +eval { + use autodie qw(copy); + my @x = copy(NO_SUCH_FILE, 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"This shouldn't change with array context"); + +# For good measure, test with built-ins. + +eval { + use autodie qw(open); + open(my $fh, '<', 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"Opening a non-existent file should throw an error"); + +eval { + use autodie qw(open); + my $x = open(my $fh, '<', 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"This shouldn't change with scalar context"); + +eval { + use autodie qw(open); + my @x = open(my $fh, '<', 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"This shouldn't change with array context"); diff --git a/cpan/autodie/t/usersub.t b/cpan/autodie/t/usersub.t new file mode 100755 index 0000000000..4266804ca9 --- /dev/null +++ b/cpan/autodie/t/usersub.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl -w +use strict; + +use Test::More 'no_plan'; + +sub mytest { + return $_[0]; +} + +is(mytest(q{foo}),q{foo},"Mytest returns input"); + +my $return = eval { mytest(undef); }; + +ok(!defined($return), "mytest returns undef without autodie"); +is($@,"","Mytest doesn't throw an exception without autodie"); + +$return = eval { + use autodie qw(mytest); + + mytest('foo'); +}; + +is($return,'foo',"Mytest returns input with autodie"); +is($@,"","No error should be thrown"); + +$return = eval { + use autodie qw(mytest); + + mytest(undef); +}; + +isa_ok($@,'autodie::exception',"autodie mytest/undef throws exception"); + +# We set initial values here because we're expecting $data to be +# changed to undef later on. Having it as undef to begin with means +# we can't see mytest(undef) working correctly. + +my ($data, $data2) = (1,1); + +eval { + use autodie qw(mytest); + + { + no autodie qw(mytest); + + $data = mytest(undef); + $data2 = mytest('foo'); + } +}; + +is($@,"","no autodie can counter use autodie for user subs"); +ok(!defined($data), "mytest(undef) should return undef"); +is($data2, "foo", "mytest(foo) should return foo"); + +eval { + mytest(undef); +}; + +is($@,"","No lingering failure effects"); + +$return = eval { + mytest("bar"); +}; + +is($return,"bar","No lingering return effects"); diff --git a/cpan/autodie/t/version.t b/cpan/autodie/t/version.t new file mode 100755 index 0000000000..a729129e88 --- /dev/null +++ b/cpan/autodie/t/version.t @@ -0,0 +1,19 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 4; + +# For the moment, we'd like all our versions to be the same. +# In order to play nicely with some code scanners, they need to be +# hard-coded into the files, rather than just nicking the version +# from autodie::exception at run-time. + +require Fatal; +require autodie; +require autodie::hints; +require autodie::exception; +require autodie::exception::system; + +is($Fatal::VERSION, $autodie::VERSION); +is($autodie::VERSION, $autodie::exception::VERSION); +is($autodie::exception::VERSION, $autodie::exception::system::VERSION); +is($Fatal::VERSION, $autodie::hints::VERSION); diff --git a/cpan/autodie/t/version_tag.t b/cpan/autodie/t/version_tag.t new file mode 100755 index 0000000000..7cb533329e --- /dev/null +++ b/cpan/autodie/t/version_tag.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More tests => 3; + +eval { + use autodie qw(:1.994); + + open(my $fh, '<', 'this_file_had_better_not_exist.txt'); +}; + +isa_ok($@, 'autodie::exception', "Basic version tags work"); + + +# Expanding :1.00 should fail, there was no autodie :1.00 +eval { my $foo = autodie->_expand_tag(":1.00"); }; + +isnt($@,"","Expanding :1.00 should fail"); + +my $version = $autodie::VERSION; + +# Expanding our current version should work! +eval { my $foo = autodie->_expand_tag(":$version"); }; + +is($@,"","Expanding :$version should succeed"); + |