File Coverage

File:lib/CheckSpelling/SummaryTables.pm
Coverage:75.3%

linestmtbrancondsubtimecode
1#! -*-perl-*-
2package CheckSpelling::SummaryTables;
3
4
1
1
1
1
105740
1
62
use Cwd 'abs_path';
5
1
1
1
1
2
1
31
use File::Basename;
6
1
1
1
1
1
1
19
use File::Temp qw/ tempfile tempdir /;
7
1
1
1
1
1
1
18
use JSON::PP;
8
1
1
1
1
166
1
848
use CheckSpelling::Util;
9
10
1
1
1
1
143
692
18
unless (eval 'use URI::Escape; 1') {
11    eval 'use URI::Escape::XS qw/uri_escape/';
12}
13
14my %git_roots = ();
15my %github_urls = ();
16my $pull_base;
17my $pull_head;
18
19sub github_repo {
20
3
3
146
    my ($source) = @_;
21
3
7
    $source =~ s<https://[^/]+/|.*:><>;
22
3
3
    $source =~ s<\.git$><>;
23
3
100
9
    return '' unless $source =~ m#^[^/]+/[^/]+$#;
24
2
3
    return $source;
25}
26
27sub file_ref {
28
1
1
1
    my ($file, $line) = @_;
29
1
2
    $file =~ s/ /%20/g;
30
1
1
    return "$file:$line";
31}
32
33sub find_git {
34
3
3
5
    our $git_dir;
35
3
100
17
    return $git_dir if defined $git_dir;
36
1
50
22
    if ($ENV{PATH} =~ /(.*)/) {
37
1
5
        my $path = $1;
38
1
12
        for my $maybe_git (split /:/, $path) {
39
11
100
38
            if (-x "$maybe_git/git") {
40
1
1
                $git_dir = $maybe_git;
41
1
7
                return $git_dir;
42            }
43        }
44    }
45}
46
47sub github_blame {
48
17
17
29422
    my ($file, $line) = @_;
49
17
9
    our (%git_roots, %github_urls, $pull_base, $pull_head);
50
51
17
50
33
    return file_ref($file, $line) if ($file =~ m{^https?://});
52
53
17
8
    my $last_git_dir;
54
17
8
    my $dir = $file;
55
17
9
    my @children;
56
17
33
48
    while ($dir ne '.' && $dir ne '/') {
57
17
250
        my $child = basename($dir);
58
17
13
        push @children, $child;
59
17
144
        my $parent = dirname($dir);
60
17
50
13
        last if $dir eq $parent;
61
17
8
        $dir = $parent;
62
17
100
18
        last if defined $git_roots{$dir};
63
2
1
        my $git_dir = "$dir/.git";
64
2
50
14
        if (-e $git_dir) {
65
2
50
6
            if (-d $git_dir) {
66
2
8
                $git_roots{$dir} = $git_dir;
67
2
1
                last;
68            }
69
0
0
0
            if (-s $git_dir) {
70
0
0
                open $git_dir_file, '<', $git_dir;
71
0
0
                my $git_dir_path = <$git_dir_file>;
72
0
0
                close $git_dir_file;
73
0
0
0
                if ($git_dir_path =~ /^gitdir: (.*)$/) {
74
0
0
                    $git_roots{$dir} = abs_path("$dir/$1");
75                }
76            }
77        }
78    }
79
17
24
    $last_git_dir = $git_roots{$dir};
80
17
7
    my $length = scalar @children - 1;
81
17
13
    for (my $i = 0; $i < $length; $i++) {
82
0
0
        $dir .= "/$children[$i]";
83
0
0
        $git_roots{$dir} = $last_git_dir;
84    }
85
86
17
50
15
    return file_ref($file, $line) unless defined $last_git_dir;
87
17
14
    $file = join '/', (reverse @children);
88
89
17
9
    my $prefix = '';
90
17
12
    my $line_delimiter = ':';
91
17
100
13
    if (defined $github_urls{$last_git_dir}) {
92
15
7
        $prefix = $github_urls{$last_git_dir};
93    } else {
94
2
5
        my $full_path = $ENV{PATH};
95
2
3
        $ENV{PATH} = find_git();
96
2
2
        my $git_dir = $ENV{GIT_DIR};
97
2
14
        $ENV{GIT_DIR} = $last_git_dir;
98
2
4343
        my $git_remotes = `git remote`;
99
2
16
        my @remotes = split /\n/, $git_remotes;
100
2
2
        my $origin;
101
2
2
50
0
9
19
        if (grep { /^origin$/ } @remotes) {
102
2
3
            $origin = 'origin';
103        } elsif (@remotes) {
104
0
0
            $origin = $remotes[0];
105        }
106
2
1
        my $remote_url;
107        my $rev;
108
2
50
4
        if ($origin) {
109
2
5485
            $remote_url = `git remote get-url "$origin" 2>/dev/null`;
110
2
9
            chomp $remote_url;
111
2
5509
            $rev = `git rev-parse HEAD 2>/dev/null`;
112
2
11
            chomp $rev;
113
2
4
            my $private_synthetic_sha = $ENV{PRIVATE_SYNTHETIC_SHA};
114
2
50
8
            if (defined $private_synthetic_sha) {
115
0
0
0
                $rev = $ENV{PRIVATE_MERGE_SHA} if ($rev eq $private_synthetic_sha);
116            }
117        }
118
2
21
        $ENV{PATH} = $full_path;
119
2
15
        $ENV{GIT_DIR} = $git_dir;
120
2
0
        my $url_base;
121
2
50
0
0
33
17
        if ($remote_url && $remote_url ne '.') {
122
2
100
11
            unless ($remote_url =~ m<^https?://>) {
123
1
30
                $remote_url =~ s!.*\@([^:]+):!https://$1/!;
124            }
125
2
6
            $remote_url =~ s!\.git$!!;
126
2
2
            $url_base = "$remote_url/blame";
127        } elsif ($ENV{GITHUB_SERVER_URL} ne '' && $ENV{GITHUB_REPOSITORY} ne '') {
128
0
0
            $url_base = "$ENV{GITHUB_SERVER_URL}/$ENV{GITHUB_REPOSITORY}/blame";
129
0
0
0
0
            $rev = $ENV{GITHUB_HEAD_REF} || $ENV{GITHUB_SHA} unless $rev;
130        }
131
2
50
2
        if ($url_base) {
132
2
50
2
            if ($pull_base) {
133
0
0
                $url_base =~ s<^$pull_base/><$pull_head/>i;
134            }
135
2
5
            $prefix = "$url_base/$rev/";
136        }
137
2
50
2
        if ($last_git_dir) {
138
2
13
            $github_urls{$last_git_dir} = $prefix;
139        }
140    }
141
17
50
30
    $line_delimiter = '#L' if $prefix =~ m<https?://>;
142
143
17
28
    $file = uri_escape($file, "^A-Za-z0-9\-\._~/");
144
17
188
    return "$prefix$file$line_delimiter$line";
145}
146
147sub main {
148
4
4
6034
    my $budget = CheckSpelling::Util::get_val_from_env("summary_budget", "");
149
4
52
    print STDERR "Summary Tables budget: $budget\n";
150
4
5
    my $summary_tables = tempdir();
151
4
568
    my $table;
152    my @tables;
153
154
4
6
    my $head_ref = CheckSpelling::Util::get_file_from_env('GITHUB_HEAD_REF', "");
155
4
3
    my $github_url = CheckSpelling::Util::get_file_from_env('GITHUB_SERVER_URL', "");
156
4
3
    my $github_repository = CheckSpelling::Util::get_file_from_env('GITHUB_REPOSITORY', "");
157
4
1
    my $event_file_path = CheckSpelling::Util::get_file_from_env('GITHUB_EVENT_PATH', "");
158
4
50
20
32
    if ($head_ref && $github_url && $github_repository && $event_file_path) {
159
4
50
42
        if (open $event_file_handle, '<', $event_file_path) {
160
4
8
            local $/;
161
4
29
            my $json = <$event_file_handle>;
162
4
9
            close $event_file_handle;
163
4
11
            my $data = decode_json($json);
164
4
1291
            our $pull_base = "$github_url/$github_repository";
165
4
3
            our $pull_head = "$github_url/".$data->{'pull_request'}->{'head'}->{'repo'}->{'full_name'};
166
4
100
50
15
            unless ($pull_head && $pull_base && ($pull_base ne $pull_head)) {
167
2
4
                $pull_base = $pull_head = '';
168            }
169        }
170    }
171
172
4
8
    while (<>) {
173
18
100
62
        next unless m{^(.+):(\d+):(\d+) \.\.\. (\d+),\s(Error|Warning|Notice)\s-\s(.+)\s\(([-a-z]+)\)$};
174
15
37
        my ($file, $line, $column, $endColumn, $severity, $message, $code) = ($1, $2, $3, $4, $5, $6, $7);
175
15
8
        my $table_file = "$summary_tables/$code";
176
15
100
75
        push @tables, $code unless -e $table_file;
177
15
215
        open $table, ">>", $table_file;
178
15
10
        $message =~ s/\|/\\|/g;
179
15
13
        my $blame = CheckSpelling::SummaryTables::github_blame($file, $line);
180
15
22
        print $table "$message | $blame\n";
181
15
164
        close $table;
182    }
183
4
100
4
    return unless @tables;
184
185
3
6
    my ($details_prefix, $footer, $suffix, $need_suffix) = (
186        "<details><summary>Details :mag_right:</summary>\n\n",
187        "</details>\n\n",
188        "\n</details>\n\n",
189        0
190    );
191
3
2
    my $footer_length = length $footer;
192
3
50
2
    if ($budget) {
193
3
3
        $budget -= (length $details_prefix) + (length $suffix);
194
3
14
        print STDERR "Summary Tables budget reduced to: $budget\n";
195    }
196
3
6
    for $table_file (sort @tables) {
197
9
7
        my $header = "<details><summary>:open_file_folder: $table_file</summary>\n\n".
198            "note|path\n".
199            "-|-\n";
200
9
3
        my $header_length = length $header;
201
9
4
        my $file_path = "$summary_tables/$table_file";
202
9
25
        my $cost = $header_length + $footer_length + -s $file_path;
203
9
100
67
15
        if ($budget && ($budget < $cost)) {
204
7
12
            print STDERR "::warning title=summary-table::Details for '$table_file' too big to include in Step Summary. (summary-table-skipped)\n";
205
7
5
            next;
206        }
207
2
13
        open $table, "<", $file_path;
208
2
2
        my @entries;
209
2
0
        my $real_cost = $header_length + $footer_length;
210
2
15
        foreach my $line (<$table>) {
211
2
0
            $real_cost += length $line;
212
2
2
            push @entries, $line;
213        }
214
2
4
        close $table;
215
2
50
3
        if ($real_cost > $cost) {
216
0
0
            print STDERR "budget ($real_cost > $cost)\n";
217
0
0
0
0
            if ($budget && ($budget < $real_cost)) {
218
0
0
                print STDERR "::warning title=summary-tables::budget exceeded for $table_file (summary-table-skipped)\n";
219
0
0
                next;
220            }
221        }
222
2
100
1
        if ($details_prefix ne '') {
223
1
9
            print $details_prefix;
224
1
0
            $details_prefix = '';
225
1
1
            $need_suffix = 1;
226        }
227
2
4
        print $header;
228
2
9
        print join ("", sort CheckSpelling::Util::case_biased @entries);
229
2
3
        print $footer;
230
2
50
2
        if ($budget) {
231
2
4
            $budget -= $cost;
232
2
5
            print STDERR "Summary Tables budget reduced to: $budget\n";
233        }
234    }
235
3
100
16
    print $suffix if $need_suffix;
236}
237
2381;