view release on metacpan or  search on metacpan

lib/Tripletail/Error.pm  view on Meta::CPAN

# -----------------------------------------------------------------------------
# Tripletail::Error - 内部クラス
# -----------------------------------------------------------------------------
package Tripletail::Error;
use strict;
use warnings;
use Data::Dumper;
#use Smart::Comments;
use Tripletail;
use overload
  '""'     => \&_stringify,
  fallback => 1;

sub _POST_REQUEST_HOOK_PRIORITY() { 2_000_000_000 } # Debug よりも後

my $PADWALKER_AVAILABLE; # PadWalker が利用可能であるかどうか。undef / 1 / 0

my $VARIABLE_LENGTH_LIMIT = 32 * 1024; # 1変数あたりの表示する最大長 (バイト)

my $DEFAULT_ERROR_TEMPLATE = &__load_default_error_template();

my $TRACE_ALLOWANCE_OF_CURRENT_REQUEST;

# 最後に発生した DB のエラー。内容は任意のハッシュ。
our $LAST_DB_ERROR;

1;

# -----------------------------------------------------------------------------
# $TL->newError($type, $msg);
# $TL->newError($type, $msg, $title);
#
sub _new {
	# スタックトレースを持った例外オブジェクトを生成する。
	# 返されたインスタンスは "" 演算子によって文字列化が可能である。
	my $class = shift;
	my $type = shift; # 'error' / 'warn' / 'file-update' / 'memory-leak'
	my $msg = shift; # $@
	my $title = shift; # 任意の文字列
	my $this = bless {} => $class;

	$this->{message} = $msg;
	$this->{type} = $type;
	$this->{title} = $title || "Error: $msg";
	$this->{frames} = []; # Tripletail::Error::Frame
	$this->{source} = {}; # ファイルパス => 中身
	$this->{show_trace} = undef;
	$this->{show_vars}  = undef;
	$this->{show_src}   = undef;
	$this->{suppress_internal} = 1;
	$this->{appear} = 'sudden'; # sudden/usertrap
	$this->{on_require} = undef; # undef/1.
	$this->{http_status_code} = undef;
	$this->{http_status_line} = undef;
	$this->{db_error} = undef;

	if( $msg =~ /: we are getting too large (file|request) which exceeds the limit. |: Post Error: request size was too big to accept. / )
	{
		$this->{http_status_code} = 413;
		$this->{http_status_line} = "413 Request Entity Too Large";
	}else
	{
		$this->{http_status_code} = 500;
		$this->{http_status_line} = "500 Internal Server Error";
	}

	my $switch = $TL->INI->get(TL => 'stacktrace', 'onlystack');
	if ($switch eq 'none') {
		# skip
	}
	elsif ($switch eq 'onlystack') {
		$this->{show_trace} = 1;
	}
	elsif ($switch eq 'full') {
		$this->{show_trace} = 1;
		$this->{show_vars}  = 1;
		$this->{show_src}   = 1;
	}
	else {
		die "Unknown stacktrace type: $switch (stacktraceの指定が不正です)";
	}

	if ($this->{show_trace} and not $this->is_trace_allowed) {
		$this->{show_trace} = undef;
	}

	if ($this->{show_trace}) {
		# TLのdieハンドラから呼ばれるかも知れないので、無限再帰を防ぐ。
		local $SIG{__DIE__} = 'DEFAULT';
		local($@);
		eval {
			$this->_fetch_frames;
		};
		if ($@) {
			print STDERR $@;
			exit 1;
		}
	}

    if (our $LAST_DB_ERROR) {

lib/Tripletail/Error.pm  view on Meta::CPAN

		if ($dump_vars) {
			my @sorted = sort keys %{$frame->vars};

			foreach my $name (@sorted) {
				my $value = $frame->vars->{$name};

				$ret .= sprintf("     %s = ", $name);

				if (length($value) >= $omission_threshold) {
					if (my $before = $already_dumped->{$value}) {
						$ret .= sprintf(
							"already dumped as %s at frame %d. skip...\n",
							$before->[0], $before->[1]);
						next;
					}
					else {
						$already_dumped->{$value} = [$name, $i];
					}
				}

				my @lines = split /\r?\n|\n/, $value;
				for (my $i = 0; $i < @lines; $i++) {
					if ($i == 0) {
						$ret .= "$lines[$i]\n";
					}
					elsif ($i == @lines - 1) {
						$ret .= "     $lines[$i];\n";
					}
					else {
						$ret .= "     $lines[$i]\n";
					}
				}
			}
		}
	}

	$ret;
}

sub _foreach_source_line {
	my ($this, $fpath, $f) = @_;
	ref $fpath and
	  $fpath = $fpath->fpath; # Tripletail::Error::Frame を許す

	my $src = $this->{source}{$fpath};

	my @lines = split /\r?\n|\r/, (defined $src ? $src : '');
	for (my $i = 0; $i < @lines; $i++) {
		$f->(
			$i + 1, sprintf('%5d |  %s', $i + 1, $lines[$i]));
	}
}

package Tripletail::Error::Frame;
use strict;
use warnings;

sub new {
	my $class = shift;
	my $this = bless {} => $class;

	$this->{level}  = shift;
	$this->{fpath}  = shift;
	$this->{line}   = shift;
	$this->{func}   = shift;
	$this->{vars}         = {}; # '$foo' => 666
	$this->{vars_shallow} = {}; # '$doo' => 'ARRAY(0x81940f8)'
	$this;
}

sub level  { shift->{level}  }
sub fpath  { shift->{fpath}  }
sub line   { shift->{line}   }
sub func   { shift->{func}   }
sub vars   { shift->{vars}   }
sub vars_shallow { shift->{vars_shallow} }

sub set_variable {
	my $this = shift;
	my $name = shift;
	my $ref  = shift;

	my $postprocess = sub {
		local($_);
		$_ = shift;
		
		s!^\\!!;
		s!^\s*|\s*$!!g;
		($name =~ m/[\@\%]/) and do {
			s!^[\[\{]!(!;
			s![\]\}]$!)!;
		};

		if (length > $VARIABLE_LENGTH_LIMIT) {
			substr($_, $VARIABLE_LENGTH_LIMIT - 3) = '...';
		}

		$_;
	};

	my $dump = Data::Dumper->new([$ref])
	  ->Indent(1)->Purity(0)->Useqq(1)->Terse(1)->Deepcopy(1)
	  ->Quotekeys(0)->Sortkeys(1)->Deparse(1)->Maxdepth(7)->Dump;
	$this->{vars}{$name} = $postprocess->($dump);

	my $shallow = Data::Dumper->new([$ref])
	  ->Indent(1)->Purity(0)->Useqq(1)->Terse(1)->Deepcopy(1)
	  ->Quotekeys(0)->Sortkeys(1)->Deparse(1)->Maxdepth(1)->Dump;
	$this->{vars_shallow}{$name} = $postprocess->($shallow);
	
	$this;
}

package Tripletail::Error;
sub __load_default_error_template
{
	# {{ DEFAULT_ERROR_TEMPLATE:
	<<'END';
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11.dtd">