libtest-fatal-perl 0.014-1 / usr / share / doc / libtest-fatal-perl / examples / convert-to-test-fatal

This file is indexed.

/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;
}

APT Browse - Built by Thomas Orozco.