File Coverage

blib/lib/Religion.pm

Criterion	Covered	Total	%
statement	31	44	70.4
branch	6	22	27.2
condition			n/a
subroutine	7	8	87.5
pod	0	2	0.0
total	44	76	57.8

package Religion;

#v3

sub import {} #nothing to export

sub TraceBack {
	# Given a starting scope offset, returns (get ready):
	#
	# Bool/Int: Am I in an eval?/How many evals are around me?
	# Integer: What is the line number of this scope?
	# String: What is the filename or eval number of this scope?
	# Integer: What is the line number of the nearest scope
	#          that is a file, not an eval?
	# String: What is the filename of the nearest scope that
	#         that is a file, not an eval?
	# String: If I were to print out a message to the user, what
	#         should I say to explain the relation of the nearest
	#         file scope to my current scope?

	my($level) = @_;
	my($iline) = (caller($level))[2];
	my($ifile) = (caller($level))[1];
	my($nil,$ofile,$oline,$sub);
	my($oscope)="";
	my($eval)=0;

  	while (($nil,$file,$line,$sub) = caller($level++)) {
	    if( $file =~ /^\(eval/ ) {
			$oline = (caller($level))[2];
			$oscope .= "the eval at line $oline of ";
			$eval++;
	    } else {
	    	return ($eval,$iline,$ifile,$line,$file,$oscope);
	    }
	}

	die "Unable to trace scope"; # This can't happen.

}

sub TraceBackHandler {
	my($sub,$oldhandler,$startlevel) = @_;

	return sub {
		my($msg,$fmsg,@trace,$level,$eval);

		# This section has been moved out to $SIG{__DIE__} and WARN.

		#if(@_==1) {
		#	# Invoked by die(), warn(), etc.;
		#	$msg = $_[0];
		#	$msg =~ s/ at (\S+|\(.*\)) line \d+\.\n$//;
		#	$level=$startlevel;
		#	@trace = Religion::TraceBack($level+1);
		#
		#	$fmsg = $msg . ((substr($msg,-1,1) ne "\n") ?
		#				 " at line $trace[1] of $trace[5]$trace[4].\n"
		#				 #" at $trace[2] line $trace[1].\n"
		#				 : "");
		#} else {
			($msg,$fmsg,$level,@trace) = @_;
		#}

		my(@result);
		my($result)="last";
		#anonymous block:
		{

			@result=&$sub($msg,$fmsg,$level+1,@trace);
			$result="return";

			$msg = $result[0] if @result>0;
			$fmsg = $result[1] if @result>1;
			$level = $result[2]-1 if @result>2;
			@trace[0..$#result-3] = @result[3..$#result] if @result>3;

			if(@result==1) {
				$fmsg = $msg . ((substr($msg,-1,1) ne "\n") ?
						 " at line $trace[1] of $trace[5]$trace[4].\n"
						 #" at $trace[2] line $trace[1].\n"
						 : "");
			}

		} continue {
			$result="next" if $result ne "return";

			if($oldhandler) {
				return &$oldhandler($msg,$fmsg,$level+1,@trace);
			}
		}

		# Return parsed info, whether we got single or multiple args
		if( $result eq "return") {
			($msg,$fmsg,$level,@trace);
		} elsif( $result eq "next") {
			next;
		} else {
			last;
		}
	}
};


package Warn;

$Handler = $PreHandler = "";

$SIG{__WARN__} = sub {
	local($^W) = 0;
	my($msg,$fmsg,@trace,$level,@trace);

	$msg = $_[0];
	$msg =~ s/ at (\S+|\(.*\)) line \d+\.\n$//;
	$level=0;
	@trace = Religion::TraceBack($level+1);

	$fmsg = $msg . ((substr($msg,-1,1) ne "\n") ?
			 " at line $trace[1] of $trace[5]$trace[4].\n"
			 #" at $trace[2] line $trace[1].\n"
			 : "");

	unshift(@trace,$msg,$fmsg,$level);

	my($ok)=0;
	{
			my(@result);
			@result=&$PreHandler(@trace) if $PreHandler;

			@trace[0..$#result]=@result;
	} continue {
			$ok=1;
	}
	return if !$ok;

	my($ok)=0;
	{
			my(@result);
			@result=&$Handler(@trace) if $Handler;

			#$result[2]++ if $#result>=2;
			@trace[0..$#result]=@result;
	} continue {
		$ok=1;
	}
	return if !$ok;

	warn($trace[1]);
};

package WarnHandler;

sub new {
	my($pkg,$sub) = @_;
	return Religion::TraceBackHandler ($sub,$Warn::Handler,0);
};

package WarnPreHandler;

sub new {
	my($pkg,$sub) = @_;
	return Religion::TraceBackHandler ($sub,$Warn::PreHandler,0);
};


package Die;

$Handler = $PreHandler = "";

$SIG{__DIE__} = sub {
	local($^W) = 0; # This cuts out warnings about exiting subs via
					# next or last.
	my($msg,$fmsg,@trace,$level,@trace);

	$msg = $_[0];
	$msg =~ s/ at (\S+|\(.*\)) line \d+\.\n$//;
	$level=0;
	@trace = Religion::TraceBack($level+1);

	$fmsg = $msg . ((substr($msg,-1,1) ne "\n") ?
			 " at line $trace[1] of $trace[5]$trace[4].\n"
			 #" at $trace[2] line $trace[1].\n"
			 : "");

	unshift(@trace,$msg,$fmsg,$level);

	my($ok)=0;
	{
			my(@result);
			@result = &$PreHandler(@trace) if $PreHandler;

			#$result[2]++ if $#result>=2;
			@trace[0..$#result]=@result;
	} continue {
			$ok=1;
	}
	die($trace[1]) if !$ok;

	my($ok)=0;
	{
			my(@result);
			@result = &$Handler(@trace) if $Handler;

			#$result[2]++ if $#result>=2;
			@trace[0..$#result]=@result;
	} continue {
		$ok=1;
	}

	die($trace[1]);
};

package DieHandler;

sub new {
	my($pkg,$sub) = @_;
	return Religion::TraceBackHandler ($sub,$Die::Handler,0);
};

package DiePreHandler;

sub new {
	my($pkg,$sub) = @_;
	return Religion::TraceBackHandler ($sub,$Die::PreHandler,0);
};


package Religion;


1;

__END__;