Rewritten error handling, so that proper line numbers are reported

diff --git a/UCW/Temple.pm b/UCW/Temple.pm
index ffbb28b1c9140cb1fbe1365bced1cc400c58d282..82d264f11a7989153443757b976ca317f1565f4e 100644 (file)
--- 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 0cff4b173f971f30938f3a568ba7f7408c5a0696..90ab406fd7edad2a4fe79b50a8594650f3d58517 100644 (file)
--- 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):