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