view release on metacpan or  search on metacpan

lib/CGI/Application/Plugin/DebugMessage.pm  view on Meta::CPAN

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 = "<hr />\n" . $self->dump_html() . "<p>Debug Messages:</p>\n<ol>\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 .= "</ol>\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