podman

1
#!/usr/bin/perl
2
#
3
# pr-removes-fixed-skips - if PR says "Fixes: #123", no skips should mention 123
4
#
5
package Podman::CI::PrRemovesFixedSkips;
6

7
use v5.14;
8
use utf8;
9

10
# Grumble. CI system doesn't have 'open'
11
binmode STDIN,  ':utf8';
12
binmode STDOUT, ':utf8';
13

14
use strict;
15
use warnings;
16

17
(our $ME = $0) =~ s|.*/||;
18
our $VERSION = '0.1';
19

20
###############################################################################
21
# BEGIN boilerplate args checking, usage messages
22

23
sub usage {
24
    print  <<"END_USAGE";
25
Usage: $ME [OPTIONS]
26

27
$ME reads a GitHub PR message, looks for
28
Fixed/Resolved/Closed issue IDs, then greps for test files
29
containing 'Skip' instructions or FIXME comments referencing
30
those IDs. If we find any, we abort with a loud and hopefully
31
useful message.
32

33
$ME is intended to run from Cirrus CI.
34

35
OPTIONS:
36

37
  --help         display this message
38
  --version      display program name and version
39
END_USAGE
40

41
    exit;
42
}
43

44
# Command-line options.  Note that this operates directly on @ARGV !
45
our $debug   = 0;
46
sub handle_opts {
47
    use Getopt::Long;
48
    GetOptions(
49
        'debug!'     => \$debug,
50

51
        help         => \&usage,
52
        version      => sub { print "$ME version $VERSION\n"; exit 0 },
53
    ) or die "Try `$ME --help' for help\n";
54
}
55

56
# END   boilerplate args checking, usage messages
57
###############################################################################
58

59
############################## CODE BEGINS HERE ###############################
60

61
# The term is "modulino".
62
__PACKAGE__->main()                                     unless caller();
63

64
# Main code.
65
sub main {
66
    # Note that we operate directly on @ARGV, not on function parameters.
67
    # This is deliberate: it's because Getopt::Long only operates on @ARGV
68
    # and there's no clean way to make it use @_.
69
    handle_opts();                      # will set package globals
70

71
    die "$ME: This script takes no arguments; try $ME --help\n"  if @ARGV;
72

73
    # Check commit messages from both github and git; they often differ
74
    my @issues = fixed_issues(cirrus_change_message(), git_commit_messages())
75
        or exit 0;
76

77
    my @found = unremoved_skips(@issues)
78
        or exit 0;
79

80
    # Found unremoved skips. Fail loudly.
81
    my $issues = "issue #$issues[0]";
82
    if (@issues > 1) {
83
        $issues = "issues #" . join ", #", @issues;
84
    }
85

86
    warn "$ME: Your PR claims to resolve $issues\n";
87
    warn "    ...but does not remove associated Skips/FIXMEs:\n";
88
    warn "\n";
89
    warn "   $_\n" for @found;
90
    warn "\n";
91
    warn <<"END_ADVICE";
92
Please do not leave Skips or FIXMEs for closed issues.
93

94
If an issue is truly fixed, please remove all Skips referencing it.
95

96
If an issue is only PARTIALLY fixed, please file a new issue for the
97
remaining problem, and update remaining Skips to point to that issue.
98

99
And if the issue is fixed but the Skip needs to remain for other
100
reasons, again, please update the Skip message accordingly.
101
END_ADVICE
102
    exit 1;
103
}
104

105
#####################
106
#  unremoved_skips  #  Returns list of <path>:<lineno>:<skip string> matches
107
#####################
108
sub unremoved_skips {
109
    my $issues = join('|', @_);
110

111
    my $re = "(^\\s\+skip|fixme).*#($issues)[^0-9]";
112
    # FIXME FIXME FIXME: use File::Find instead of enumerating directories
113
    # (the important thing here is to exclude vendor)
114
    my @grep = ('grep', '-E', '-rin', $re, "test", "cmd", "libpod", "pkg");
115

116
    my @skips;
117
    open my $grep_fh, '-|', @grep
118
        or die "$ME: Could not fork: $!\n";
119
    while (my $line = <$grep_fh>) {
120
        chomp $line;
121

122
        # e.g., test/system/030-run.bats:809:   skip "FIXME: #12345 ..."
123
        $line =~ m!^(\S+):\d+:\s!
124
            or die "$ME: Internal error: output from grep does not match <path>:<lineno>:<space>: '$line'";
125
        my $path = $1;
126

127
        # Any .go or .bats file, or the apply-podman-deltas script
128
        if ($path =~ /\.(go|bats)$/ || $path =~ m!/apply-podman-deltas$!) {
129
            push @skips, $line;
130
        }
131

132
        # Anything else is probably a backup file, or something else
133
        # we don't care about. (We won't see these in CI, but might
134
        # in a user devel environment)
135
        elsif ($debug) {
136
            print "[ ignoring: $line ]\n";
137
        }
138
    }
139
    close $grep_fh;
140

141
    return sort @skips;
142
}
143

144
##################
145
#  fixed_issues  #  Parses change message, looks for Fixes/Closes/Resolves
146
##################
147
sub fixed_issues {
148
    my @issues;
149

150
    for my $msg (@_) {
151
        # https://docs.github.com/en/issues/tracking-your-work-with-issues/linking-a-pull-request-to-an-issue#linking-a-pull-request-to-an-issue-using-a-keyword
152
        #
153
        #                 1               1              2   2
154
        while ($msg =~ /\b(Fix|Clos|Resolv)[esd]*[:\s]+\#(\d+)/gis) {
155
            # Skip dups: we're probably checking both github and git messages
156
            push @issues, $2
157
                unless grep { $_ eq $2 } @issues;
158
        }
159
    }
160

161
    return @issues;
162
}
163

164
###########################
165
#  cirrus_change_message  #  this is the one from *GitHub*, not *git*
166
###########################
167
sub cirrus_change_message {
168
    my $change_message = $ENV{CIRRUS_CHANGE_MESSAGE}
169
        or do {
170
            # OK for it to be unset if we're not running CI on a PR
171
            return if ! $ENV{CIRRUS_PR};
172
            # But if we _are_ running on a PR, something went badly wrong.
173
            die "$ME: \$CIRRUS_CHANGE_MESSAGE is undefined\n";
174
        };
175

176
    return $change_message;
177
}
178

179
#########################
180
#  git_commit_messages  #  the ones from the *git history*
181
#########################
182
sub git_commit_messages {
183
    # Probably the same as HEAD, but use Cirrus-defined value if available
184
    my $head = $ENV{CIRRUS_CHANGE_IN_REPO} || 'HEAD';
185

186
    # Base of this PR. Here we absolutely rely on cirrus.
187
    return if ! $ENV{DEST_BRANCH};
188
    chomp(my $base = qx{git merge-base $ENV{DEST_BRANCH} $head});
189

190
    qx{git log --format=%B $base..$head};
191
}
192

193
1;
194