author/convert-to-test-fatal

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use File::Slurp qw( write_file );
   7 use PPI;
   8
   9 rewrite_doc($_) for grep { -w } @ARGV;
  10
  11 sub rewrite_doc {
  12     my $file = shift;
  13
  14     my $doc = PPI::Document->new($file);
  15
  16     return unless $doc =~ /Test::Exception/;
  17
  18     print $file, "\n";
  19
  20     my $pattern = sub {
  21         my $elt = $_[1];
  22
  23         return 1
  24             if $elt->isa('PPI::Statement')
  25                 && $elt->content()
  26                 =~ /^\s*(?:::)?(?:lives_|throws_|dies_)(?:ok|and)/;
  27
  28         return 0;
  29     };
  30
  31     for my $elt ( @{ $doc->find($pattern) || [] } ) {
  32         transform_statement($elt);
  33     }
  34
  35     my $content = $doc->content();
  36     $content =~ s/Test::Exception/Test::Fatal/g;
  37
  38     write_file( $file, $content );
  39 }
  40
  41 sub transform_statement {
  42     my $stmt = shift;
  43
  44     my @children = $stmt->schildren;
  45
  46     my $func = shift @children;
  47
  48     my $colons = $func =~ /^::/ ? '::' : q{};
  49
  50     my $code;
  51     if ( $func =~ /lives_/ ) {
  52         $code = function(
  53             $colons . 'is',
  54             $children[0],
  55             'undef',
  56             $children[1]
  57         );
  58     }
  59     elsif ( $func =~ /dies_/ ) {
  60         $code = function(
  61             $colons . 'isnt',
  62             $children[0],
  63             'undef',
  64             $children[1]
  65         );
  66     }
  67     elsif ( $func =~ /throws_/ ) {
  68
  69         # $children[2] is always a comma if it exists
  70         if ( $children[1]->isa('PPI::Token::QuoteLike::Regexp') ) {
  71             $code = function(
  72                 $colons . 'like',
  73                 $children[0],
  74                 $children[1],
  75                 $children[3]
  76             );
  77         }
  78         else {
  79             $code = function(
  80                 $colons . 'is',
  81                 $children[0],
  82                 $children[1],
  83                 $children[3]
  84             );
  85         }
  86     }
  87
  88     $stmt->insert_before($code);
  89     $stmt->remove;
  90 }
  91
  92 sub function {
  93     my $func      = shift;
  94     my $exception = shift;
  95     my $expect    = shift;
  96     my $desc      = shift;
  97
  98     my $exc_func = $func =~ /^::/ ? '::exception' : 'exception';
  99
 100     my @code;
 101
 102     push @code,
 103         PPI::Token::Word->new($func),
 104         PPI::Token::Structure->new('('),
 105         PPI::Token::Whitespace->new(q{ }),
 106         PPI::Token::Word->new($exc_func),
 107         PPI::Token::Whitespace->new(q{ }),
 108         $exception->clone,
 109         PPI::Token::Operator->new(','),
 110         PPI::Token::Whitespace->new(q{ }),
 111         ( ref $expect ? $expect->clone : PPI::Token::Word->new($expect) );
 112
 113     if ( $desc && $desc->isa('PPI::Token::Quote') ) {
 114         push @code, PPI::Token::Operator->new(','),
 115             PPI::Token::Whitespace->new(q{ }),
 116             $desc->clone;
 117     }
 118
 119     push @code,
 120         PPI::Token::Whitespace->new(q{ }),
 121         PPI::Token::Structure->new(')'),
 122         PPI::Token::Structure->new(';');
 123
 124     my $stmt = PPI::Statement->new;
 125     $stmt->add_element($_) for @code;
 126
 127     return $stmt;
 128 }