1#!/usr/bin/perl -w
2use strict;
3use warnings;
4use Fatal;
5use 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
17my %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
27while (my ($proto, $code) = each %protos) {
28    is_deeply( [ Fatal::fill_protos($proto) ], $code, $proto);
29}
30
31# write_invocation tests
32no 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
38my @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) {
46return CORE::open($_[0]) || croak "Can't open(@_): $!"	} elsif (@_ == 2) {
47return CORE::open($_[0], $_[1]) || croak "Can't open(@_): $!"	} elsif (@_ == 3) {
48return 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
55foreach my $test (@write_invocation_calls) {
56    is(Fatal::write_invocation( @{ $test->[0] } ), $test->[1], 'write_inovcation');
57}
58
59# one_invocation tests.
60
61my @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
74foreach 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.
82