Commit | Line | Data |
9b657a62 |
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. |