File Coverage

blib/lib/Test2/Plugin/GitHub/Actions/AnnotateWarnings.pm

Criterion	Covered	Total	%
statement	33	39	84.6
branch	6	10	60.0
condition	2	8	25.0
subroutine	10	11	90.9
pod			n/a
total	51	68	75.0

package Test2::Plugin::GitHub::Actions::AnnotateWarnings;
use 5.008001;
use strict;
use warnings;

use Test2::API qw(test2_stderr);
use URI::Escape qw(uri_escape);

our $VERSION = "0.01";

sub __ignore_no_warnings {
    my ($message, $filename, $line) = @_;
    return 0;
}

# By default, no warning is ignored.
my $ignore_if = \&__ignore_no_warnings;

my $_orig_warn_handler;

sub import {
    my ($class, %args) = @_;

    return unless $ENV{GITHUB_ACTIONS};

    $ignore_if = $args{ignore_if} if exists $args{ignore_if};

    $_orig_warn_handler = $SIG{__WARN__};

    $SIG{__WARN__} = sub {
        my (undef, $file, $line) = caller;
        my $message = $_[0] // "Warning: Something's wrong";
        chomp $message;
        $message = _escape_data($message);

        my $stderr = test2_stderr();
        _issue_warning($file, $line, $message) unless $ignore_if->($message, $file, $line);

        # from Test::Warnings
        # TODO: this doesn't handle blessed coderefs... does anyone care?
        if ($_orig_warn_handler and ((ref $_orig_warn_handler eq 'CODE') or ($_orig_warn_handler ne 'DEFAULT' and $_orig_warn_handler ne 'IGNORE' and defined &$_orig_warn_handler))) {
            goto &$_orig_warn_handler;
        }
    };
}

sub unimport {
    my ($class) = @_;

    $ignore_if = \&__ignore_no_warnings;
    $SIG{__WARN__} = $_orig_warn_handler;
}

sub _issue_warning {
    my ($file, $line, $detail) = @_;

    my $stderr = test2_stderr();

    if (length $detail) {
        $stderr->printf("::warning file=%s,line=%d::%s\n", $file, $line, _escape_data($detail));
    } else {
        $stderr->printf("::warning file=%s,line=%d\n", $file, $line);
    }
}

# escape a message of workflow command.
# see also: https://github.com/actions/toolkit/blob/30e0a77337213de5d4e158b05d1019c6615f69fd/packages/core/src/command.ts#L92-L97
sub _escape_data {
    my ($msg) = @_;
    return uri_escape($msg, "%\r\n");
}

1;
__END__