File Coverage

blib/lib/Devel/Events/Filter/Warn.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

#!/usr/bin/perl

package Devel::Events::Filter::Warn;
use Moose;

use overload ();
use Scalar::Util qw(blessed reftype looks_like_number);

with qw/Devel::Events::Filter::HandlerOptional/;

has pretty => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has kvp => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has stringify => (
	isa => "Bool",
	is  => "rw",
	default => 0,
);

sub filter_event {
	my ( $self, @event ) = @_;

	if ( $self->pretty ) {
		my ( $name, @data ) = @event;

		if ( $self->kvp ) {
			my $output = "$name:";

			my $even = 1;
			foreach my $field ( @data ) {
				if ( $even ) {
					$output .= " $field =>";
				} else {
					$output .= " " . $self->_make_printable($field) . ",";
				}

				$even = !$even;
			}

			$output =~ s/,$| =>$//;

			warn "$output\n";
		} else {
			warn "$name: " . join(" ", map { $self->_make_printable($_) } @data );
		}
	} else {
		no warnings 'uninitialized';
		warn "@event\n";
	}

	return @event;
}

sub _make_printable {
	my ( $self, $field, $no_rec ) = @_;

	defined($field)
		? ( ref($field)
			? blessed($field)
				? $self->stringify ? "$field" : overload::StrVal($field)
				: ( reftype($field) eq 'ARRAY' && !$no_rec
					?  "[ " . join(", ", map { $self->_make_printable( $_, 1 ) } @$field ) . " ]"
					: "$field" )
			: ( looks_like_number($field)
				? $field
				: do {
					my $str = $field;
					# FIXME require String::Escape
					$str =~ s/\n/\\n/g;
					$str =~ s/\r/\\r/g;
					qq{"$str"}
				} ) )
		: "undef"
}

__PACKAGE__;

__END__

=pod

=head1 NAME

Devel::Events::Filter::Warn - log every event to STDERR

=head1 SYNOPSIS

	# can be used as a handler
	my $h = Devel::Events::Filter::Warn->new();

	# or as a filter in a handler chain

	my $f = Devel::Events::Filter::Warn->new(
		handler => $sub_handler,
	);

=head1 DESCRIPTION

This is a very simple debugging aid to see that your filter/handler chains are
set up correctly.

A useful helper function you can define is something along the lines of:

	sub _warn_events ($) {
		my $handler = shift;
		Devel::Events::Filter::Warn->new( handler => $handler );
	}

and then prefix handlers which seem to not be getting their events with
C<_warn_events> in the source code.

=head1 METHODS

=over 4

=item filter_event @event

calls C<warn "@event">. and returns the event unfiltered.

=back

=cut