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