This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update the Change log in Module::CoreList to include recent commits
[perl5.git] / cpan / autodie / t / internal-backcompat.t
1 #!/usr/bin/perl -w
2 use strict;
3 use warnings;
4 use Fatal;
5 use Test::More 'no_plan';
6
7 # Tests to determine if Fatal's internal interfaces remain backwards
8 # compatible.
9 #
10 # WARNING: This file contains a lot of very ugly code, hard-coded
11 # strings, and nasty API calls.  It may frighten small children.
12 # Viewer discretion is advised.
13
14 # fill_protos.  This hasn't been changed since the original Fatal,
15 # and so should always be the same.
16
17 my %protos = (
18     '$'     => [ [ 1, '$_[0]' ] ],
19     '$$'    => [ [ 2, '$_[0]', '$_[1]' ] ],
20     '$$@'   => [ [ 3, '$_[0]', '$_[1]', '@_[2..$#_]' ] ],
21     '\$'    => [ [ 1, '${$_[0]}' ] ],
22     '\%'    => [ [ 1, '%{$_[0]}' ] ],
23     '\%;$*' => [ [ 1, '%{$_[0]}' ], [ 2, '%{$_[0]}', '$_[1]' ],
24                  [ 3, '%{$_[0]}', '$_[1]', '$_[2]' ] ],
25 );
26
27 while (my ($proto, $code) = each %protos) {
28     is_deeply( [ Fatal::fill_protos($proto) ], $code, $proto);
29 }
30
31 # write_invocation tests
32 no warnings 'qw';
33
34 # Technically the outputted code varies from the classical Fatal.
35 # However the changes are mostly whitespace.  Those that aren't are
36 # improvements to error messages.
37
38 my @write_invocation_calls = (
39     [
40         # Core  # Call          # Name  # Void  # Args
41         [ 1,    'CORE::open',   'open', 0,      [ 1, qw($_[0]) ],
42                                                 [ 2, qw($_[0] $_[1]) ],
43                                                 [ 3, qw($_[0] $_[1] @_[2..$#_])]
44         ],
45         q{      if (@_ == 1) {
46 return CORE::open($_[0]) || croak "Can't open(@_): $!"  } elsif (@_ == 2) {
47 return CORE::open($_[0], $_[1]) || croak "Can't open(@_): $!"   } elsif (@_ == 3) {
48 return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"
49             }
50             die "Internal error: open(@_): Do not expect to get ", scalar(@_), " arguments";
51     }
52     ]
53 );
54
55 foreach my $test (@write_invocation_calls) {
56     is(Fatal::write_invocation( @{ $test->[0] } ), $test->[1], 'write_inovcation');
57 }
58
59 # one_invocation tests.
60
61 my @one_invocation_calls = (
62         # Core  # Call          # Name  # Void   # Args
63     [
64         [ 1,    'CORE::open',   'open', 0,      qw($_[0] $_[1] @_[2..$#_]) ],
65         q{return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"},
66     ],
67     [
68         [ 1,    'CORE::open',   'open', 1,      qw($_[0] $_[1] @_[2..$#_]) ],
69         q{return (defined wantarray)?CORE::open($_[0], $_[1], @_[2..$#_]):
70                    CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"},
71     ],
72 );
73
74 foreach my $test (@one_invocation_calls) {
75     is(Fatal::one_invocation( @{ $test->[0] } ), $test->[1], 'one_inovcation');
76 }
77
78 # TODO: _make_fatal
79 # Since this subroutine has always started with an underscore,
80 # I think it's pretty clear that it's internal-only.  I'm not
81 # testing it here, and it doesn't yet have backcompat.