view release on metacpan or  search on metacpan

lib/Plack/Middleware/Test/StashWarnings.pm  view on Meta::CPAN

package Plack::Middleware::Test::StashWarnings;

use strict;
use 5.008_001;
our $VERSION = '0.08';

use parent qw(Plack::Middleware);
use Carp ();
use Storable 'nfreeze';

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self = $class->SUPER::new(@_);
    $self->{verbose} = $ENV{TEST_VERBOSE} unless defined $self->{verbose};
    return $self;
}

sub call {
    my ($self, $env) = @_;

    if ($env->{PATH_INFO} eq '/__test_warnings') {
        Carp::carp("Use a single process server like Standalone to run Test::StashWarnings middleware")
            if $env->{'psgi.multiprocess'} && $self->{multiprocess_warn}++ == 0;

        return [ 200, ["Content-Type", "application/x-storable"], [ $self->dump_warnings ] ];
    }

    my $ret = $self->_stash_warnings_for($self->app, $env);

    # for the streaming API, we need to re-instate the dynamic sigwarn handler
    # around the streaming callback
    if (ref($ret) eq 'CODE') {
        return sub { $self->_stash_warnings_for($ret, @_) };
    }

    return $ret;
}

sub _stash_warnings_for {
    my $self = shift;
    my $code = shift;

    my $old_warn = $SIG{__WARN__} || sub { warn @_ };
    local $SIG{__WARN__} = sub {
        $self->add_warning(@_);
        $old_warn->(@_) if $self->{verbose};
    };

    return $code->(@_);
}

sub add_warning {
    my $self = shift;
    push @{ $self->{stashed_warnings} }, @_;
}

sub dump_warnings {
    my $self = shift;

    return nfreeze([ splice @{ $self->{stashed_warnings} } ]);
}

sub DESTROY {
    my $self = shift;
    for (splice @{ $self->{stashed_warnings} }) {
        warn "Unhandled warning: $_";
    }
}

1;
__END__

=encoding utf-8

=for stopwords

=head1 NAME

Plack::Middleware::Test::StashWarnings - Test your application's warnings

=head1 SYNOPSIS

  # for your PSGI application:
  enable "Test::StashWarnings";


  # for your Test::WWW::Mechanize subclass:
  use Storable 'thaw';
  sub get_warnings {
      local $Test::Builder::Level = $Test::Builder::Level + 1;
      my $self = shift;