File Coverage

blib/lib/CGI/Application/Plugin/DebugMessage.pm

Criterion	Covered	Total	%
statement	59	78	75.6
branch	10	38	26.3
condition	6	20	30.0
subroutine	10	12	83.3
pod	2	5	40.0
total	87	153	56.8

package CGI::Application::Plugin::DebugMessage;

use 5.006;
use strict;
use warnings;

use CGI::Application 3.21;
use Carp qw(croak);

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
	debug
	debug_ocode
);
our $VERSION = '0.01';
my $prefix = "CAP_DeubgMessage";

sub import {
	my $caller = scalar(caller);
	$caller->add_callback('postrun', 'CGI::Application::Plugin::DebugMessage::log2footer');
	goto &Exporter::import;
}

sub debug {
	my $self = shift;
	my @added = @_;
	if (@added) {
		my $footer = $self->param("${prefix}_footer") || [];
		my $caller = bless([caller(0)], "${prefix}::Caller");
		@added = map { [$caller, $_] } @added;
		push(@{$footer}, @added);
		$self->param("${prefix}_footer" => $footer)
	}
}

sub debug_ocode {
	my $self  = shift;
	my $code  = shift;
	$self->param("${prefix}_code" => $code) if (UNIVERSAL::can($self, 'param'));
}

sub log2footer {
	my $self   = shift;
	my $ref    = shift;
	my $footer = $self->param("${prefix}_footer") ? $self->param("${prefix}_footer") : [];
	return unless ($footer and ref($footer) eq 'ARRAY' and @{$footer});
	my $html = "\n" . $self->dump_html() . "Debug Messages:\n\n";
	foreach my $message (@{$footer}) {
		my $string = '';
		my $caller = undef;
		($caller, $message) = @{$message} if (ref($message) eq 'ARRAY' and @{$message} and ref($message->[0]) eq "${prefix}::Caller");
		$caller = sprintf("[%s(%s)] ", $caller->[0], $caller->[2]) if ($caller);
		# HTML escape and dump (if necessary)
		if (ref($message)) {
			$string = CGI::Application::Plugin::DebugMessage::dump_pretty($self, $message);
			$string = CGI->pre($string);
		} else {
			$string = CGI->escapeHTML($message);
		}
		$string = CGI::Application::Plugin::DebugMessage::convert_code($self, $string) if ($self->param("${prefix}_code"));
		$html .= CGI->li($caller . $string) . "\n";
	}
	$html .= "\n";
	$$ref =~ s/(<\/html>|$)/$html$1/i;
}

sub dump_pretty {
	my $self = shift;
	eval '
		use Data::Dumper;
		local $Data::Dumper::Indent = 1;
		local $Data::Dumper::Sortkeys = 1;
		local $Data::Dumper::Terse = 1;
	';
	return join(", ", @_) if ($@);
	return unless (@_);
	my $dump = Dumper(@_);
	return $dump;
}

sub convert_code {
	my $self  = shift;
	my $str   = shift;
	my $ref   = ref($str) ? $str : \$str;
	my $class = ref($self) ? ref($self) : $self;
	my $ocode = $self->param("${prefix}_code");
	return $str unless (length($str));
	return $str unless ($ocode);
	# Use Jcode
	eval "use Jcode";
	return $str if ($@);
	# Guess input code
	my ($icode, $match) = Jcode::getcode($$ref);
	$icode = 'euc' if ($icode eq undef and $match > 0);
	if ($icode eq 'euc') {
		my $re_sjis = '[\201-\237\340-\374][\100-\176\200-\374]|[\241-\337]|[\x00-\x7F]';
		my $re_euc  = '[\241-\376][\241-\376]|\216[\241-\337]|\217[\241-\376][\241-\376]|[\x00-\x7F]';
		$icode = 'sjis' if ($$ref !~ /^(?:$re_euc)*$/o and $str =~ /^(?:$re_sjis)*$/o);
	}
	# Convert
	$$ref = Jcode::jcode($ref, $icode)->$ocode if ($icode ne $ocode);
}

1;
__END__