From 3e4681922a8ff5b364b6aee96cdf7841202da3b0 Mon Sep 17 00:00:00 2001
From: Martin Mares <mj@ucw.cz>
Date: Fri, 12 Oct 2012 22:43:44 +0200
Subject: [PATCH] Rewritten error handling, so that proper line numbers are
 reported

---
 UCW/Temple.pm | 71 ++++++++++++++++++++++++++++++++++++++-------------
 test          |  4 ++-
 2 files changed, 56 insertions(+), 19 deletions(-)

diff --git a/UCW/Temple.pm b/UCW/Temple.pm
index ffbb28b..82d264f 100644
--- a/UCW/Temple.pm
+++ b/UCW/Temple.pm
@@ -1,5 +1,5 @@
 # A really simple template engine
-# (c) 2004--2008 Martin Mares <mj@ucw.cz>
+# (c) 2004--2012 Martin Mares <mj@ucw.cz>
 
 package UCW::Temple;
 
@@ -29,6 +29,28 @@ sub add_depend($) {
 	$deps{$_[0]} = 1;
 }
 
+my $current_file_name;
+my $current_string;
+my $current_pos;
+
+sub error($;$) {
+	my ($msg, $offset) = @_;
+	if (defined $current_file_name) {
+		#
+		#  This is rather tricky. We want to report the exact place, where the error
+		#  occurred, but the cost of keeping track of the current line number is too high.
+		#  Hence we keep just the current position inside the input stream and convert
+		#  it to the line number only when reporting an error.
+		#
+		my $input = substr(${$current_string}, 0, $current_pos);
+		my @newlines = ($input =~ m{\n}g);
+		my $line = @newlines + ($offset // 1);
+		die "$current_file_name:$line: $msg\n";
+	} else {
+		die "$msg\n";
+	}
+}
+
 sub get_nested($$$) {
 	my ($r,$left,$right) = @_;
 	pos $$r = pos($$r)-1;
@@ -41,7 +63,7 @@ sub get_nested($$$) {
 		} elsif ($$r =~ /\G([$right])/cgs) {
 			$nest--;
 		} else {
-			die "File ended when looking for matching $right";
+			error "File ended when looking for matching $right";
 		}
 		$z .= $1;
 	} while ($nest);
@@ -53,7 +75,13 @@ sub eval_if_ok($) {
 		my $x = shift;
 		my $res = eval "package T; $x";
 		return $res unless $@;
-		die "Error evaluating $x: $@";
+		my $m = $@;
+		chomp $m;
+		if (my ($msg, $line) = $m =~ m{(.*) at \(eval \d+\) line (\d+)\.$}) {
+			error $msg, $line;
+		} else {
+			error $m;
+		}
 	} else {
 		return "";
 	}
@@ -63,23 +91,23 @@ sub eval_func($$) {
 	my ($f, $a) = @_;
 	if ($f =~ /^(if|fi|else|elif)$/) {
 		if ($f eq "if") {
-			$a ne "()" or die "\@if requires an argument";
+			$a ne "()" or error "\@if requires an argument";
 			if ($cond[0] > 0) {
 				unshift @cond, (eval_if_ok($a) ? 1 : -1);
 			} else {
 				unshift @cond, 0;
 			}
 		} elsif ($f eq "fi") {
-			$a eq "()" or die "\@fi takes no arguments";
-			$#cond or die "\@fi without \@if";
+			$a eq "()" or error "\@fi takes no arguments";
+			$#cond or error "\@fi without \@if";
 			shift @cond;
 		} elsif ($f eq "else") {
-			$a eq "()" or die "\@else takes no arguments";
-			$#cond or die "\@else without \@if";
+			$a eq "()" or error "\@else takes no arguments";
+			$#cond or error "\@else without \@if";
 			$cond[0] = -$cond[0];
 		} elsif ($f eq "elif") {
-			$a ne "()" or die "\@elif requires an argument";
-			$#cond or die "\@elif without \@if";
+			$a ne "()" or error "\@elif requires an argument";
+			$#cond or error "\@elif without \@if";
 			if ($cond[0] > 0) {
 				$cond[0] = 0;
 			} elsif ($cond[0] < 0) {
@@ -94,10 +122,14 @@ sub eval_func($$) {
 	}
 }
 
-sub parse_string($) {
-	my ($t) = @_;
+sub parse_string($$) {
+	my ($t, $name) = @_;
+	my ($old_fn, $old_str, $old_pos) = ($current_file_name, $current_string, $current_pos);
+	$current_file_name = $name;
+	$current_string = \$t;
 	pos $t = 0;
 	for(;;) {
+		$current_pos = pos $t;
 		if ($t =~ /\G([^\@]+)/cgs) {
 			out $1 if $cond[0] > 0;
 		} elsif ($t =~ /\G\@\s*\n/cgs) {
@@ -128,24 +160,25 @@ sub parse_string($) {
 		} elsif ($t =~ /\G\@(\$\w+)/cgs) {
 			out eval_if_ok($1);
 		} elsif ($t =~ /\G(\@[^\n]*)/cgs) {
-			die "Unknown control sequence $1";
+			error "Unknown control sequence $1";
 		} elsif ($t =~ /\G$/cgs) {
 			last;
 		} elsif ($t =~ /\G([^\n]*)/cgs) {
-			die "Internal parser error at $1 (pos " . pos($t) . ")";
+			error "Internal parser error";
 		} else { die; }
 	}
+	($current_file_name, $current_string, $current_pos) = ($old_fn, $old_str, $old_pos);
 }
 
 sub parse_file($) {
 	my ($name) = @_;
 	add_depend($name);
 	my $fh = new IO::File $name;
-	die "Unable to open $name: $!" unless defined $fh;
+	error "Unable to open $name: $!" unless defined $fh;
 	my $text;
 	{ local $/; undef $/; $text = <$fh>; }
 	undef $fh;
-	parse_string($text);
+	parse_string($text, $name);
 }
 
 sub start(;$)
@@ -156,7 +189,7 @@ sub start(;$)
 
 sub finish()
 {
-	$#cond and die "Unterminated \@if (depth $#cond)";
+	$#cond and error "Unterminated \@if (depth $#cond)";
 }
 
 sub process_file($;$) {
@@ -169,7 +202,7 @@ sub process_file($;$) {
 sub process_string($;$) {
 	my ($string, $args) = @_;
 	start($args);
-	parse_string($string);
+	parse_string($string, '<string>');
 	finish();
 }
 
@@ -179,6 +212,8 @@ package T;
 
 import UCW::Temple;
 
+# Beware: Functions in the T package should report errors via die(), not error().
+
 our $temp;
 our $out_func = sub { print @_; };
 
diff --git a/test b/test
index 0cff4b1..90ab406 100644
--- a/test
+++ b/test
@@ -39,7 +39,9 @@ I was run as @$0.
 @out "Four", "Five", "Six\n"
 
 @# Of course you can define your own functions (they live in the T:: namespace)
-@[ sub quork($) { my ($arg) = @_; return "Thus quoth the Penguin: $arg"; } ]
+@[ sub quork($) { my ($arg) = @_;
+return "Thus quorkth the Penguin: $arg";
+} ]
 @quork("404!")
 
 @# There are also some conditionals (you can use any perl expressions):
-- 
2.39.5