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.